diff --git a/dune-project b/dune-project index 9918780e4..c12280cdb 100644 --- a/dune-project +++ b/dune-project @@ -73,4 +73,24 @@ (or (<> :os-distribution "centos") (> :os-version 7)))) (eio_posix (and (= :version) (<> :os "win32"))) (eio_windows (and (= :version) (= :os "win32"))))) +(package + (name eio_js_backend) + (synopsis "Simple Eio scheduler for JavaScript environments") + (description "An Eio scheduler suitable for JavaScript environments.") + (depends + (eio (= :version)))) +(package + (name eio_brr) + (synopsis "Eio support for Brr") + (description "This package provides Eio variants of Brr functions, which returns directly instead of returning a future.") + (depends + (eio_js_backend (= :version)) + (brr (>= 0.0.4)))) +(package + (name js_of_ocaml-eio) + (synopsis "Eio-based JavaScript bindings") + (description "An Eio counterpart to package js_of_ocaml-lwt.") + (depends + (eio_js_backend (= :version)) + (js_of_ocaml (>= 5.0.1)))) (using mdx 0.2) diff --git a/eio_brr.opam b/eio_brr.opam new file mode 100644 index 000000000..7118a5151 --- /dev/null +++ b/eio_brr.opam @@ -0,0 +1,32 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Eio support for Brr" +description: + "This package provides Eio variants of Brr functions, which returns directly instead of returning a future." +maintainer: ["anil@recoil.org"] +authors: ["Anil Madhavapeddy" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/ocaml-multicore/eio" +doc: "https://ocaml-multicore.github.io/eio/" +bug-reports: "https://github.com/ocaml-multicore/eio/issues" +depends: [ + "dune" {>= "3.9"} + "eio" {= version} + "brr" {>= "0.0.4"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/ocaml-multicore/eio.git" diff --git a/eio_js_backend.opam b/eio_js_backend.opam new file mode 100644 index 000000000..b1ffc09ce --- /dev/null +++ b/eio_js_backend.opam @@ -0,0 +1,30 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Simple Eio scheduler for JavaScript environments" +description: "An Eio scheduler suitable for JavaScript environments." +maintainer: ["anil@recoil.org"] +authors: ["Anil Madhavapeddy" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/ocaml-multicore/eio" +doc: "https://ocaml-multicore.github.io/eio/" +bug-reports: "https://github.com/ocaml-multicore/eio/issues" +depends: [ + "dune" {>= "3.9"} + "eio" {= version} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/ocaml-multicore/eio.git" diff --git a/js_of_ocaml-eio.opam b/js_of_ocaml-eio.opam new file mode 100644 index 000000000..6ded5ab94 --- /dev/null +++ b/js_of_ocaml-eio.opam @@ -0,0 +1,31 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Eio-based JavaScript bindings" +description: "An Eio counterpart of package js_of_ocaml-lwt." +maintainer: ["anil@recoil.org"] +authors: ["Anil Madhavapeddy" "Thomas Leonard"] +license: "ISC" +homepage: "https://github.com/ocaml-multicore/eio" +doc: "https://ocaml-multicore.github.io/eio/" +bug-reports: "https://github.com/ocaml-multicore/eio/issues" +depends: [ + "dune" {>= "3.9"} + "eio" {= version} + "js_of_ocaml" {>= "5.0.1"} + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/ocaml-multicore/eio.git" diff --git a/lib_eio_brr/dune b/lib_eio_brr/dune new file mode 100644 index 000000000..9bed861ea --- /dev/null +++ b/lib_eio_brr/dune @@ -0,0 +1,6 @@ +(library + (name eio_brr) + (public_name eio_brr) + (wrapped false) + (modes byte) + (libraries eio_js_backend brr)) diff --git a/lib_eio_brr/eio_brr.ml b/lib_eio_brr/eio_brr.ml new file mode 100644 index 000000000..0561e4dd3 --- /dev/null +++ b/lib_eio_brr/eio_brr.ml @@ -0,0 +1,46 @@ +let start = Eio_js_backend.start + +module Blob = struct + let array_buffer b = Eio_fut.await_exn (Brr.Blob.array_buffer b) + let text b = Eio_fut.await_exn (Brr.Blob.text b) + let data_uri b = Eio_fut.await_exn (Brr.Blob.data_uri b) +end + +module Ev = struct + let next ?capture typ target = Eio_fut.await (Brr.Ev.next ?capture typ target) + + module Data_transfer = struct + module Item = struct + let get_jstr i = Eio_fut.await (Brr.Ev.Data_transfer.Item.get_jstr i) + end + end + + module Extendable = struct + let wait_until e ~sw f = + Brr.Ev.Extendable.wait_until e (Eio_fut.make_exn ~sw f) + end +end + +module El = struct + let request_pointer_lock e = Eio_fut.await_exn (Brr.El.request_pointer_lock e) + + let request_fullscreen ?opts e = + Eio_fut.await_exn (Brr.El.request_fullscreen ?opts e) +end + +module Document = struct + let exit_pointer_lock e = Eio_fut.await (Brr.Document.exit_pointer_lock e) + let exit_fullscreen e = Eio_fut.await_exn (Brr.Document.exit_fullscreen e) +end + +module G = struct + let set_timeout ~ms = + Eio_js_backend.await + ~setup:(fun ~resolve ~reject:_ -> Brr.G.set_timeout ~ms resolve) + ~cancel:Brr.G.stop_timer + + let request_animation_frame () = + Eio_js_backend.await + ~setup:(fun ~resolve ~reject:_ -> Brr.G.request_animation_frame resolve) + ~cancel:Brr.G.cancel_animation_frame +end diff --git a/lib_eio_brr/eio_brr.mli b/lib_eio_brr/eio_brr.mli new file mode 100644 index 000000000..a127c02df --- /dev/null +++ b/lib_eio_brr/eio_brr.mli @@ -0,0 +1,100 @@ +(** {1 Eio scheduler setup} *) + +val start : (unit -> unit) -> unit +(** [start f] executes function [f] asynchronously in a context where + Eio operations can be performed. + + This function is an alias for {!Eio_js_scheduler.start}. +*) + +(** {1 Eio variants of Brr functions} *) + +(** {2:data Data containers and encodings} *) + +(** Blob objects. *) +module Blob : sig + val array_buffer : Brr.Blob.t -> Brr.Tarray.Buffer.t + (** [array_buffer b] is an + {{:https://developer.mozilla.org/en-US/docs/Web/API/Blob/arrayBuffer} + array buffer} with the contents of [b]. *) + + val text : Brr.Blob.t -> Jstr.t + (** [text b] is the + {{:https://developer.mozilla.org/en-US/docs/Web/API/Blob/text}string} + that results from UTF-8 decoding the contents of [b]. *) + + val data_uri : Brr.Blob.t -> Jstr.t + (** [data_uri b] is [b] as a data URI (via the + {{:https://developer.mozilla.org/en-US/docs/Web/API/FileReader} + [FileReader]} API). *) +end + +(** {2 DOM interaction} *) + +(** DOM events. *) +module Ev : sig + val next : ?capture:bool -> 'a Brr.Ev.type' -> Brr.Ev.target -> 'a Brr.Ev.t + (** [next type' t] returns the next event of type [type'] on target [t]. *) + + (** [DataTransfer] objects. *) + module Data_transfer : sig + (** [DataTransferItem] objects. *) + module Item : sig + val get_jstr : Brr.Ev.Data_transfer.Item.t -> Jstr.t + (** [get_jstr i] is the item's text. *) + end + end + + module Extendable : sig + val wait_until : + Brr.Ev.Extendable.t -> sw:Eio.Switch.t -> (unit -> _) -> unit + (** [wait_until e ~sw fn] {{:https://developer.mozilla.org/en-US/docs/Web/API/ExtendableEvent/waitUntil}indicates} to the event dispatcher that work is ongoing. Function [fn] is run in a new fiber attached to [sw]. The work is considered completed when [fn] returns. *) + end +end + +(** DOM elements. *) +module El : sig + (** {1 Pointer locking} *) + + val request_pointer_lock : Brr.El.t -> unit + (** [request_pointer_lock e] requests the pointer to be locked + to [e] in the document it belongs to. This listens on the + document for the next [Brr.Ev.pointerlockchange] and + [Brr.Ev.pointerlockerror] to resolve the future appropriately. *) + + (** {1 Fullscreen} *) + + val request_fullscreen : ?opts:Brr.El.fullscreen_opts -> Brr.El.t -> unit + (** [request_fullscreen e] requests to make the element + to be displayed in fullscreen mode. *) +end + +(** [Document] objects *) +module Document : sig + (** {1 Pointer locking} *) + + val exit_pointer_lock : Brr.Document.t -> unit + (** [exit_pointer_lock d] {{:https://developer.mozilla.org/en-US/docs/Web/API/Document/exitPointerLock}exits} pointer lock mode. This returns + when the corresponding [Brr.Ev.pointerlockchange] on [d] has fired. *) + + (** {1 Fullscreen} + + Use {!El.request_fullscreen} to get into fullscreen mode. *) + + val exit_fullscreen : Brr.Document.t -> unit + (** [exit_fullscreen d] + {{:https://developer.mozilla.org/en-US/docs/Web/API/Document/exitFullscreen}exits} fullscreen mode. *) +end + +(** The global object, its global objects and functions. *) +module G : sig + val set_timeout : ms:int -> unit + (** [set_timeout ~ms] is a timer waiting for [ms] milliseconds. It + can be cancelled. *) + + val request_animation_frame : unit -> float + (** [request_animation_frame ()] + {{:https://developer.mozilla.org/en-US/docs/Web/API/Window/requestAnimationFrame}waits} + until right before the next repaint. It returns the current + point in time. It can be cancelled. *) +end diff --git a/lib_eio_brr/eio_brr_canvas.ml b/lib_eio_brr/eio_brr_canvas.ml new file mode 100644 index 000000000..7c9678f0f --- /dev/null +++ b/lib_eio_brr/eio_brr_canvas.ml @@ -0,0 +1,4 @@ +module Canvas = struct + let to_blob ?encode c = + Eio_fut.await_exn (Brr_canvas.Canvas.to_blob ?encode c) +end diff --git a/lib_eio_brr/eio_brr_canvas.mli b/lib_eio_brr/eio_brr_canvas.mli new file mode 100644 index 000000000..cf279f289 --- /dev/null +++ b/lib_eio_brr/eio_brr_canvas.mli @@ -0,0 +1,10 @@ +(** Canvas element. *) +module Canvas : sig + val to_blob : + ?encode:Brr_canvas.Canvas.image_encode -> + Brr_canvas.Canvas.t -> + Brr.Blob.t option + (** [to_blob ~encode t] is the canvas's image a blob object. [None] + is returned either if the canvas has no pixels or if an error + occurs during image serialisation. *) +end diff --git a/lib_eio_brr/eio_brr_io.ml b/lib_eio_brr/eio_brr_io.ml new file mode 100644 index 000000000..efd0fd46d --- /dev/null +++ b/lib_eio_brr/eio_brr_io.ml @@ -0,0 +1,108 @@ +module Clipboard = struct + module Item = struct + let get_type i t = Eio_fut.await_exn (Brr_io.Clipboard.Item.get_type i t) + end + + let read c = Eio_fut.await_exn (Brr_io.Clipboard.read c) + let read_text c = Eio_fut.await_exn (Brr_io.Clipboard.read_text c) + let write c is = Eio_fut.await_exn (Brr_io.Clipboard.write c is) + let write_text c s = Eio_fut.await_exn (Brr_io.Clipboard.write_text c s) +end + +module Fetch = struct + let wrap_abort abort = + Option.map (fun abort () -> Brr.Abort.abort abort) abort + + module Body = struct + let array_buffer ?abort b = + Eio_fut.await_exn ?abort:(wrap_abort abort) + (Brr_io.Fetch.Body.array_buffer b) + + let blob ?abort b = + Eio_fut.await_exn ?abort:(wrap_abort abort) (Brr_io.Fetch.Body.blob b) + + let form_data ?abort b = + Eio_fut.await_exn ?abort:(wrap_abort abort) + (Brr_io.Fetch.Body.form_data b) + + let json ?abort b = + Eio_fut.await_exn ?abort:(wrap_abort abort) (Brr_io.Fetch.Body.json b) + + let text ?abort b = + Eio_fut.await_exn ?abort:(wrap_abort abort) (Brr_io.Fetch.Body.text b) + end + + module Cache = struct + let match' ?query_opts c req = + Eio_fut.await_exn (Brr_io.Fetch.Cache.match' ?query_opts c req) + + let match_all ?query_opts c req = + Eio_fut.await_exn (Brr_io.Fetch.Cache.match_all ?query_opts c req) + + let add c req = Eio_fut.await_exn (Brr_io.Fetch.Cache.add c req) + let add_all c reqs = Eio_fut.await_exn (Brr_io.Fetch.Cache.add_all c reqs) + let put c req resp = Eio_fut.await_exn (Brr_io.Fetch.Cache.put c req resp) + + let delete ?query_opts c req = + Eio_fut.await_exn (Brr_io.Fetch.Cache.delete ?query_opts c req) + + let keys ?query_opts ?req c = + Eio_fut.await_exn (Brr_io.Fetch.Cache.keys ?query_opts ?req c) + + module Storage = struct + let match' ?query_opts s req = + Eio_fut.await_exn (Brr_io.Fetch.Cache.Storage.match' ?query_opts s req) + + let has s n = Eio_fut.await_exn (Brr_io.Fetch.Cache.Storage.has s n) + let open' s n = Eio_fut.await_exn (Brr_io.Fetch.Cache.Storage.open' s n) + let delete s n = Eio_fut.await_exn (Brr_io.Fetch.Cache.Storage.delete s n) + let keys s = Eio_fut.await_exn (Brr_io.Fetch.Cache.Storage.keys s) + end + end + + module Ev = struct + let preload_response e = + Eio_fut.await_exn (Brr_io.Fetch.Ev.preload_response e) + + let handled e = Eio_fut.await_exn (Brr_io.Fetch.Ev.handled e) + + let respond_with e ~sw fn = + Brr_io.Fetch.Ev.respond_with e (Eio_fut.make_exn ~sw fn) + end + + let url ?abort ?init u = + Eio_fut.await_exn ?abort:(wrap_abort abort) (Brr_io.Fetch.url ?init u) + + let request ?abort r = + Eio_fut.await_exn ?abort:(wrap_abort abort) (Brr_io.Fetch.request r) +end + +module Geolocation = struct + let get ?opts l = Eio_fut.await (Brr_io.Geolocation.get ?opts l) +end + +module Media = struct + module Track = struct + let apply_constraints t cstrs = + Eio_fut.await_exn (Brr_io.Media.Track.apply_constraints t cstrs) + end + + module Devices = struct + let enumerate m = Eio_fut.await_exn (Brr_io.Media.Devices.enumerate m) + + let get_user_media m c = + Eio_fut.await_exn (Brr_io.Media.Devices.get_user_media m c) + + let get_display_media m c = + Eio_fut.await_exn (Brr_io.Media.Devices.get_display_media m c) + end + + module El = struct + let play m = Eio_fut.await_exn (Brr_io.Media.El.play m) + end +end + +module Notification = struct + let request_permission () = + Eio_fut.await_exn (Brr_io.Notification.request_permission ()) +end diff --git a/lib_eio_brr/eio_brr_io.mli b/lib_eio_brr/eio_brr_io.mli new file mode 100644 index 000000000..4b80a4e59 --- /dev/null +++ b/lib_eio_brr/eio_brr_io.mli @@ -0,0 +1,292 @@ +(** Clipboard access + + See the {{:https://developer.mozilla.org/en-US/docs/Web/API/Clipboard} + Clipboard API}. *) +module Clipboard : sig + (** Clipboard items. *) + module Item : sig + val get_type : Brr_io.Clipboard.Item.t -> Jstr.t -> Brr.Blob.t + (** [get_type i t] is the {{:https://developer.mozilla.org/en-US/docs/Web/API/ClipboardItem/getType}blob object} with MIME type [t] for item [i]. *) + end + + (** {1:rw Reading and writing} *) + + val read : Brr_io.Clipboard.t -> Brr_io.Clipboard.Item.t list + (** [read c] is the {{:https://developer.mozilla.org/en-US/docs/Web/API/Clipboard/read}content} of [c]. *) + + val read_text : Brr_io.Clipboard.t -> Jstr.t + (** [read_text c] is the clipboard {{:https://developer.mozilla.org/en-US/docs/Web/API/Clipboard/readText}textual content} of [c]. *) + + val write : Brr_io.Clipboard.t -> Brr_io.Clipboard.Item.t list -> unit + (** [write c is] + {{:https://developer.mozilla.org/en-US/docs/Web/API/Clipboard/write} + writes} the items [is] to [c]. *) + + val write_text : Brr_io.Clipboard.t -> Jstr.t -> unit + (** [write_text c s] + {{:https://developer.mozilla.org/en-US/docs/Web/API/Clipboard/writeText} + writes} the string [s] to [c]. *) +end + +(** Fetching resources. + + See the {{:https://developer.mozilla.org/en-US/docs/Web/API/Fetch_API} + Fetch API}. *) +module Fetch : sig + (** Body specification and interface. *) + module Body : sig + val array_buffer : + ?abort:Brr.Abort.t -> Brr_io.Fetch.Body.t -> Brr.Tarray.Buffer.t + (** [array_buffer ?abort b] + {{:https://developer.mozilla.org/en-US/docs/Web/API/Body/arrayBuffer} + reads} [b] into an array buffer. If the fiber is cancelled, + the optional controller [abort] is used to cancel the fetch + operation. *) + + val blob : ?abort:Brr.Abort.t -> Brr_io.Fetch.Body.t -> Brr.Blob.t + (** [blob ?abort b] + {{:https://developer.mozilla.org/en-US/docs/Web/API/Body/blob} + reads} [b] as a blob. If the fiber is cancelled, the optional + controller [abort] is used to cancel the fetch operation. *) + + val form_data : + ?abort:Brr.Abort.t -> Brr_io.Fetch.Body.t -> Brr_io.Form.Data.t + (** [form_data ?abort b] + {{:https://developer.mozilla.org/en-US/docs/Web/API/Body/formData} + reads} [b] as form data. If the fiber is cancelled, the + optional controller [abort] is used to cancel the fetch + operation. *) + + val json : ?abort:Brr.Abort.t -> Brr_io.Fetch.Body.t -> Brr.Json.t + (** [json ?abort b] + {{:https://developer.mozilla.org/en-US/docs/Web/API/Body/json} + reads} [b] and parses it as JSON data. If the fiber is + cancelled, the optional controller [abort] is used to cancel + the fetch operation. *) + + val text : ?abort:Brr.Abort.t -> Brr_io.Fetch.Body.t -> Jstr.t + (** [text ?abort b] + {{:https://developer.mozilla.org/en-US/docs/Web/API/Body/text}reads} + [b] and UTF-8 decodes it to a string. If the fiber is + cancelled, the optional controller [abort] is used to cancel + the fetch operation. *) + end + + (** Fetch caches. *) + module Cache : sig + val match' : + ?query_opts:Brr_io.Fetch.Cache.query_opts -> + Brr_io.Fetch.Cache.t -> + Brr_io.Fetch.Request.t -> + Brr_io.Fetch.Response.t option + (** [match' c req] is a {{:https://developer.mozilla.org/en-US/docs/Web/API/Cache/match}stored response} for [req] in [c] (if any). *) + + val match_all : + ?query_opts:Brr_io.Fetch.Cache.query_opts -> + Brr_io.Fetch.Cache.t -> + Brr_io.Fetch.Request.t -> + Brr_io.Fetch.Response.t list + (** [match_all c req] is a list {{:https://developer.mozilla.org/en-US/docs/Web/API/Cache/matchAll}stored response} for [req] in [c]. *) + + val add : Brr_io.Fetch.Cache.t -> Brr_io.Fetch.Request.t -> unit + (** [add c req] fetches [req] and + {{:https://developer.mozilla.org/en-US/docs/Web/API/Cache/add}adds} + the response to [c]. *) + + val add_all : Brr_io.Fetch.Cache.t -> Brr_io.Fetch.Request.t list -> unit + (** [add_all c reqs] fetches [reqs] and + {{:https://developer.mozilla.org/en-US/docs/Web/API/Cache/addAll}adds} + their reponses to [c]. *) + + val put : + Brr_io.Fetch.Cache.t -> + Brr_io.Fetch.Request.t -> + Brr_io.Fetch.Response.t -> + unit + (** [put c req resp] + {{:https://developer.mozilla.org/en-US/docs/Web/API/Cache/put}puts} + the [req]/[resp] pair to the cache. *) + + val delete : + ?query_opts:Brr_io.Fetch.Cache.query_opts -> + Brr_io.Fetch.Cache.t -> + Brr_io.Fetch.Request.t -> + bool + (** [delete c req] {{:https://developer.mozilla.org/en-US/docs/Web/API/Cache/delete}deletes} response to [req] from the cache. [false] + is returned if [req] was not in the cache. *) + + val keys : + ?query_opts:Brr_io.Fetch.Cache.query_opts -> + ?req:Brr_io.Fetch.Request.t -> + Brr_io.Fetch.Cache.t -> + Brr_io.Fetch.Request.t list + (** [keys c] are the {{:https://developer.mozilla.org/en-US/docs/Web/API/Cache/keys}requests} cached by [c]. *) + + (** {1:cache_storage Cache storage} *) + + (** Cache storage objects. *) + module Storage : sig + val match' : + ?query_opts:Brr_io.Fetch.Cache.query_opts -> + Brr_io.Fetch.Cache.Storage.t -> + Brr_io.Fetch.Request.t -> + Brr_io.Fetch.Response.t option + (** [match' s req] is a {{:https://developer.mozilla.org/en-US/docs/Web/API/CacheStorage/match}stored response} for [req] in [s] (if any). *) + + val has : Brr_io.Fetch.Cache.Storage.t -> Jstr.t -> bool + (** [has s n] is [true] if [n] matches a {{:https://developer.mozilla.org/en-US/docs/Web/API/CacheStorage/has}cache name} in [s]. *) + + val open' : + Brr_io.Fetch.Cache.Storage.t -> + Jstr.t -> + Brr_io.Fetch.Cache.Storage.cache + (** [open' s n] {{:https://developer.mozilla.org/en-US/docs/Web/API/CacheStorage/open}opens} the cache named [n] of [s]. *) + + val delete : Brr_io.Fetch.Cache.Storage.t -> Jstr.t -> bool + (** [delete s n] {{:https://developer.mozilla.org/en-US/docs/Web/API/CacheStorage/delete}deletes} the cache named [n] from [s]. [false] is returned + if [n] did not exist. *) + + val keys : Brr_io.Fetch.Cache.Storage.t -> Jstr.t list + (** [keys s] are the {{:https://developer.mozilla.org/en-US/docs/Web/API/CacheStorage/keys}cache names} in [s]. *) + end + end + + (** Fetch events. *) + module Ev : sig + val preload_response : Brr_io.Fetch.Ev.t -> Brr_io.Fetch.Response.t option + (** [preload_response e] is a navigation response {{:https://developer.mozilla.org/en-US/docs/Web/API/FetchEvent/preloadResponse}preload} (if any). *) + + val handled : Brr_io.Fetch.Ev.t -> unit + (** [handled e] is obscure. *) + + val respond_with : + Brr_io.Fetch.Ev.t -> + sw:Eio.Switch.t -> + (unit -> Brr_io.Fetch.Response.t) -> + unit + (** [respond_with e ~sw fn] replace the browser's default fetch handling + with the {{:https://developer.mozilla.org/en-US/docs/Web/API/FetchEvent/respondWith} + response} [fn []]. Function [fn] is run in a new fiber attached to [sw]. *) + end + + val url : + ?abort:Brr.Abort.t -> + ?init:Brr_io.Fetch.Request.init -> + Jstr.t -> + Brr_io.Fetch.Response.t + (** [url ?abort ~init u] + {{:https://developer.mozilla.org/en-US/docs/Web/API/WindowOrWorkerGlobalScope/fetch}fetches} + URL [u] with the [init] request object. If the fiber is + cancelled, the optional controller [abort] is used to cancel + the fetch operation. *) + + val request : + ?abort:Brr.Abort.t -> Brr_io.Fetch.Request.t -> Brr_io.Fetch.Response.t + (** [request ?abort r] + {{:https://developer.mozilla.org/en-US/docs/Web/API/WindowOrWorkerGlobalScope/fetch}fetches} + request [r]. If the fiber is cancelled, the optional + controller [abort] is used to cancel the fetch operation. *) + + (** + Here is an example of how to use this API: + {[ + let fetch url = + let abort = Brr.Abort.controller () in + let init = Brr_io.Fetch.Request.init ~signal:(Brr.Abort.signal abort) () in + let response = Eio_brr_io.Fetch.url ~abort ~init url in + Eio_brr_io.Fetch.Body.text ~abort (Brr_io.Fetch.Response.as_body response) + ]} + *) +end + +(** Access to device location. + + See {{:https://developer.mozilla.org/en-US/docs/Web/API/Geolocation_API} + Geolocation API}. *) +module Geolocation : sig + val get : + ?opts:Brr_io.Geolocation.opts -> + Brr_io.Geolocation.t -> + (Brr_io.Geolocation.Pos.t, Brr_io.Geolocation.Error.t) result + (** [get l ~opts] is the position of [l] + {{:https://developer.mozilla.org/en-US/docs/Web/API/Geolocation/getCurrentPosition}determined} + with options [opts]. *) +end + +module Media : sig + (** {1:media Media devices, streams and tracks} *) + + (** Media stream tracks. *) + module Track : sig + val apply_constraints : + Brr_io.Media.Track.t -> Brr_io.Media.Constraints.t option -> unit + (** [apply_contraints t] applies the + {{:https://developer.mozilla.org/en-US/docs/Web/API/MediaStreamTrack/applyConstraints}applies} + the given contraints. Constraints unspecified are restored to + their default value. If no contraints are given all + contraints are restored to their defaults. *) + end + + (** Media device enumeration. *) + module Devices : sig + val enumerate : Brr_io.Media.Devices.t -> Brr_io.Media.Device.Info.t list + (** [enumerate m] + {{:https://developer.mozilla.org/en-US/docs/Web/API/MediaDevices/enumerateDevices}determines} + a list of connected media devices. Monitor changes by listening + {!Ev.devicechange} on [m]. *) + + val get_user_media : + Brr_io.Media.Devices.t -> + Brr_io.Media.Stream.Constraints.t -> + Brr_io.Media.Stream.t + (** [get_user_media m c] + {{:https://developer.mozilla.org/en-US/docs/Web/API/MediaDevices/getUserMedia}prompts} + the user to use a media input which can produce a media stream + constrained by [c]. + {{:https://developer.mozilla.org/en-US/docs/Web/API/MediaDevices/getUserMedia#Exceptions}These + errors} can occur. In particular [Jv.Error.Not_allowed] and + [Jv.Error.Not_found] should be reported to the user in a + friendly way. In some browsers this call has to done + in a user interface event handler. *) + + val get_display_media : + Brr_io.Media.Devices.t -> + Brr_io.Media.Stream.Constraints.t -> + Brr_io.Media.Stream.t + (** [get_display_media m c] + {{:https://developer.mozilla.org/en-US/docs/Web/API/MediaDevices/getDisplayMedia}prompts} the user to select and grant permission to capture the + contents of a display as a media stream. A video + track is unconditionally returned even if [c] says otherwise. + In some browsers this call has to done in a user interface event + handler. + + See this + {{:https://developer.mozilla.org/en-US/docs/Web/API/Screen_Capture_API/Using_Screen_Capture}MDN article} for more details. *) + end + + (** {1:el Media element interface} *) + + (** The HTML {{:https://developer.mozilla.org/en-US/docs/Web/API/HTMLMediaElem +ent}media element interface}. + + {b Warning.} This binding is incomplete, the modules + {!El.Audio_track}, {!El.Video_track}, {!El.Text_track} are mostly + empty. *) + module El : sig + val play : Brr_io.Media.El.t -> unit + (** [play m] + {{:https://developer.mozilla.org/en-US/docs/Web/API/HTMLMediaElement/play}plays} [m]. *) + end +end + +(** Notifying users. + + See the {{:https://developer.mozilla.org/en-US/docs/Web/API/Notifications_AP +I}Notification API}. *) +module Notification : sig + (** {1:perm Permission} *) + + val request_permission : unit -> Brr_io.Notification.Permission.t + (** [request_permission ()] {{:https://developer.mozilla.org/en-US/docs/Web/API/Notification/requestPermission}requests} permission to display + notifications. *) +end diff --git a/lib_eio_brr/eio_brr_webaudio.ml b/lib_eio_brr/eio_brr_webaudio.ml new file mode 100644 index 000000000..67d9ba8c9 --- /dev/null +++ b/lib_eio_brr/eio_brr_webaudio.ml @@ -0,0 +1,29 @@ +module Audio = struct + module Worklet = struct + let add_module w url = + Eio_fut.await_exn (Brr_webaudio.Audio.Worklet.add_module w url) + end + + module Context = struct + module Base = struct + let decode_audio_data t b = + Eio_fut.await_exn + (Brr_webaudio.Audio.Context.Base.decode_audio_data t b) + end + + let resume c = Eio_fut.await_exn (Brr_webaudio.Audio.Context.resume c) + let suspend c = Eio_fut.await_exn (Brr_webaudio.Audio.Context.suspend c) + let close c = Eio_fut.await_exn (Brr_webaudio.Audio.Context.close c) + + module Offline = struct + let start_rendering c = + Eio_fut.await_exn (Brr_webaudio.Audio.Context.Offline.start_rendering c) + + let suspend c ~secs = + Eio_fut.await_exn (Brr_webaudio.Audio.Context.Offline.suspend c ~secs) + + let resume c = + Eio_fut.await_exn (Brr_webaudio.Audio.Context.Offline.resume c) + end + end +end diff --git a/lib_eio_brr/eio_brr_webaudio.mli b/lib_eio_brr/eio_brr_webaudio.mli new file mode 100644 index 000000000..5aef031af --- /dev/null +++ b/lib_eio_brr/eio_brr_webaudio.mli @@ -0,0 +1,58 @@ +(** Web Audio API. + + See the {{:https://developer.mozilla.org/en-US/docs/Web/API/Web_Audio_API} + Web Audio API}. *) + +(** Web Audio. *) +module Audio : sig + (** Audio worklets, their global scope and processors. *) + module Worklet : sig + (** {1:worklets Worklets} *) + val add_module : Brr_webaudio.Audio.Worklet.t -> Jstr.t -> unit + (** [add_module w url] {{:https://developer.mozilla.org/en-US/docs/Web/API/Worklet/addModule}adds} module [url] to [w]. *) + end + + (** Audio contexts. *) + module Context : sig + (** {1:base_contexts Base audio contexts} *) + + (** Base audio contexts. *) + module Base : sig + (** {1:audio_context Audio contexts} *) + + val decode_audio_data : + Brr_webaudio.Audio.Context.Base.t -> + Brr_webaudio.Audio.Buffer.t -> + Brr_webaudio.Audio.Buffer.t + (** [decode_audio_data t b] + {{:https://developer.mozilla.org/en-US/docs/Web/API/BaseAudioContext/decodeAudioData}decodes} the audio data in [b]. *) + end + + (** {1:audio_context Audio contexts} *) + + val resume : Brr_webaudio.Audio.Context.t -> unit + (** [resume c] {{:https://developer.mozilla.org/en-US/docs/Web/API/AudioContext/resume}resumes} progression of time in [c]. *) + + val suspend : Brr_webaudio.Audio.Context.t -> unit + (** [suspend c] {{:https://developer.mozilla.org/en-US/docs/Web/API/AudioContext/suspend}suspend} progression of time in [c]. *) + + val close : Brr_webaudio.Audio.Context.t -> unit + (** [close c] {{:https://developer.mozilla.org/en-US/docs/Web/API/AudioContext/close}closes} the audio context [c]. *) + + (** {1:offline_context Offline audio contexts} *) + + (** Offline audio contexts. *) + module Offline : sig + val start_rendering : + Brr_webaudio.Audio.Context.Offline.t -> Brr_webaudio.Audio.Buffer.t + (** [start_rendering c] {{:https://developer.mozilla.org/en-US/docs/Web/API/OfflineAudioContext/startRendering}starts} rendering the audio graph + and determines with the rendered audio buffer. *) + + val suspend : Brr_webaudio.Audio.Context.Offline.t -> secs:float -> unit + (** [suspend c] {{:https://developer.mozilla.org/en-US/docs/Web/API/OfflineAudioContext/suspend}suspends} rendering for [secs] seconds. *) + + val resume : Brr_webaudio.Audio.Context.Offline.t -> unit + (** [resume c] {{:https://developer.mozilla.org/en-US/docs/Web/API/OfflineAudioContext/resume}resumes} rendering. *) + end + end +end diff --git a/lib_eio_brr/eio_brr_webcrypto.ml b/lib_eio_brr/eio_brr_webcrypto.ml new file mode 100644 index 000000000..6da25994a --- /dev/null +++ b/lib_eio_brr/eio_brr_webcrypto.ml @@ -0,0 +1,48 @@ +module Subtle_crypto = struct + let encrypt s a k data = + Eio_fut.await_exn (Brr_webcrypto.Subtle_crypto.encrypt s a k data) + + let decrypt s a k data = + Eio_fut.await_exn (Brr_webcrypto.Subtle_crypto.decrypt s a k data) + + let digest s a data = + Eio_fut.await_exn (Brr_webcrypto.Subtle_crypto.digest s a data) + + let sign s a k data = + Eio_fut.await_exn (Brr_webcrypto.Subtle_crypto.sign s a k data) + + let verify s a k ~sig' data = + Eio_fut.await_exn (Brr_webcrypto.Subtle_crypto.verify s a k ~sig' data) + + let generate_key s a ~extractable ~usages = + Eio_fut.await_exn + (Brr_webcrypto.Subtle_crypto.generate_key s a ~extractable ~usages) + + let generate_key_pair s a ~extractable ~usages = + Eio_fut.await_exn + (Brr_webcrypto.Subtle_crypto.generate_key_pair s a ~extractable ~usages) + + let derive_bits s a k l = + Eio_fut.await_exn (Brr_webcrypto.Subtle_crypto.derive_bits s a k l) + + let derive_key s a k ~derived ~extractable ~usages = + Eio_fut.await_exn + (Brr_webcrypto.Subtle_crypto.derive_key s a k ~derived ~extractable + ~usages) + + let export_key s f k = + Eio_fut.await_exn (Brr_webcrypto.Subtle_crypto.export_key s f k) + + let import_key s f k a ~extractable ~usages = + Eio_fut.await_exn + (Brr_webcrypto.Subtle_crypto.import_key s f k a ~extractable ~usages) + + let wrap_key s f k ~wrap_key ~wrapper = + Eio_fut.await_exn + (Brr_webcrypto.Subtle_crypto.wrap_key s f k ~wrap_key ~wrapper) + + let unwrap_key s f b ~wrap_key ~wrapper ~unwrapped ~extractable ~usages = + Eio_fut.await_exn + (Brr_webcrypto.Subtle_crypto.unwrap_key s f b ~wrap_key ~wrapper + ~unwrapped ~extractable ~usages) +end diff --git a/lib_eio_brr/eio_brr_webcrypto.mli b/lib_eio_brr/eio_brr_webcrypto.mli new file mode 100644 index 000000000..2520e7beb --- /dev/null +++ b/lib_eio_brr/eio_brr_webcrypto.mli @@ -0,0 +1,148 @@ +open Brr + +(** [SubtleCrypto] objects *) +module Subtle_crypto : sig + val encrypt : + Brr_webcrypto.Subtle_crypto.t -> + Brr_webcrypto.Crypto_algo.t -> + Brr_webcrypto.Crypto_algo.t -> + ('a, 'b) Tarray.t -> + Tarray.Buffer.t + (** [encrypt s a k data] is [data] + {{:https://developer.mozilla.org/en-US/docs/Web/API/SubtleCrypto/encrypt} + encrypted} with key [k] and algorithm [a]. *) + + val decrypt : + Brr_webcrypto.Subtle_crypto.t -> + Brr_webcrypto.Crypto_algo.t -> + Brr_webcrypto.Crypto_algo.t -> + ('a, 'b) Tarray.t -> + Tarray.Buffer.t + (** [decrypt s a k data] is [data] + {{:https://developer.mozilla.org/en-US/docs/Web/API/SubtleCrypto/decrypt} + decrypted} with key [k] and algorithm [a]. *) + + val digest : + Brr_webcrypto.Subtle_crypto.t -> + Brr_webcrypto.Crypto_algo.t -> + ('a, 'b) Tarray.t -> + Tarray.Buffer.t + (** [digest s a data] is the + {{:https://developer.mozilla.org/en-US/docs/Web/API/SubtleCrypto/digest} + digest} of [data] according to algorithm [a]. *) + + (** {1:sign Signatures} *) + + val sign : + Brr_webcrypto.Subtle_crypto.t -> + Brr_webcrypto.Crypto_algo.t -> + Brr_webcrypto.Crypto_algo.t -> + ('a, 'b) Tarray.t -> + Tarray.Buffer.t + (** [sign s a k data] is the + {{:https://developer.mozilla.org/en-US/docs/Web/API/SubtleCrypto/sign} + signature} of [data] with key [k] and algorithm [a]. *) + + val verify : + Brr_webcrypto.Subtle_crypto.t -> + Brr_webcrypto.Crypto_algo.t -> + Brr_webcrypto.Crypto_algo.t -> + sig':('a, 'b) Tarray.t -> + ('c, 'd) Tarray.t -> + bool + (** [verify s a k ~sig' data] is [true] iff the signature of [data] + with key [k] and algorithm [a] + {{:https://developer.mozilla.org/en-US/docs/Web/API/SubtleCrypto/verify} + matches} [sig']. *) + + (** {1:gen Key generation} *) + + val generate_key : + Brr_webcrypto.Subtle_crypto.t -> + Brr_webcrypto.Crypto_algo.t -> + extractable:bool -> + usages:Brr_webcrypto.Crypto_key.Usage.t list -> + Brr_webcrypto.Crypto_algo.t + (** [generate_key s a ~extractable ~usage] is a key + {{:https://developer.mozilla.org/en-US/docs/Web/API/SubtleCrypto/generateKey}generated} for algorithm [a] and usages [usages]. {b Warning} + if the algorithm generates a key pair use {!generate_key_pair}. *) + + val generate_key_pair : + Brr_webcrypto.Subtle_crypto.t -> + Brr_webcrypto.Crypto_algo.t -> + extractable:bool -> + usages:Brr_webcrypto.Crypto_key.Usage.t list -> + Brr_webcrypto.Crypto_key.pair + (** [generate_key_pair s a ~extractable ~usage] is a key + {{:https://developer.mozilla.org/en-US/docs/Web/API/SubtleCrypto/generateKey}generated} of type and parameters [a] and usages [usages]. {b Warning} if + the algorithm generates a single key use {!generate_key}. *) + + (** {1:derive Key derivation} *) + + val derive_bits : + Brr_webcrypto.Subtle_crypto.t -> + Brr_webcrypto.Crypto_algo.t -> + Brr_webcrypto.Crypto_algo.t -> + int -> + Tarray.Buffer.t + (** [derive_bits s a k l] are [l] bits + {{:https://developer.mozilla.org/en-US/docs/Web/API/SubtleCrypto/deriveBits}derived} from [k] with algorithm [a]. *) + + val derive_key : + Brr_webcrypto.Subtle_crypto.t -> + Brr_webcrypto.Crypto_algo.t -> + Brr_webcrypto.Crypto_algo.t -> + derived:Brr_webcrypto.Crypto_algo.t -> + extractable:bool -> + usages:Brr_webcrypto.Crypto_key.Usage.t list -> + Brr_webcrypto.Crypto_algo.t + (** [derive_key s a k ~derived_type ~extractable ~usages] is a key + of type and parameters [~derived] and usages [usages] + {{:https://developer.mozilla.org/en-US/docs/Web/API/SubtleCrypto/deriveKey}derived} from key [k] of type and parameters [a]. *) + + (** {1:codec Key encoding and decoding} *) + + val export_key : + Brr_webcrypto.Subtle_crypto.t -> + Brr_webcrypto.Crypto_key.Format.t -> + Brr_webcrypto.Crypto_algo.t -> + [ `Buffer of Tarray.Buffer.t | `Json_web_key of Json.t ] + (** [export_key s f k] is the key [k] + {{:https://developer.mozilla.org/en-US/docs/Web/API/SubtleCrypto/exportKey}exported} in format [f]. [`Json_web_key] is only returned if + {!Brr_webcrypto.Crypto_algo.Format.jwk} is specified. *) + + val import_key : + Brr_webcrypto.Subtle_crypto.t -> + Brr_webcrypto.Crypto_key.Format.t -> + [ `Buffer of Tarray.Buffer.t | `Json_web_key of Json.t ] -> + Brr_webcrypto.Crypto_algo.t -> + extractable:bool -> + usages:Brr_webcrypto.Crypto_key.Usage.t list -> + Brr_webcrypto.Crypto_algo.t + (** [import_key s f k a ~extractable ~usages] is the key [k] + {{:https://developer.mozilla.org/en-US/docs/Web/API/SubtleCrypto/importKey}imported} from format [f] and type [a] used for [usages]. *) + + val wrap_key : + Brr_webcrypto.Subtle_crypto.t -> + Brr_webcrypto.Crypto_key.Format.t -> + Brr_webcrypto.Crypto_algo.t -> + wrap_key:Brr_webcrypto.Crypto_algo.t -> + wrapper:Brr_webcrypto.Crypto_algo.t -> + Tarray.Buffer.t + (** [wrap_key s f k ~wrap_key ~wrapper] is like {!export_key} + but {{:https://developer.mozilla.org/en-US/docs/Web/API/SubtleCrypto/wrapKey}encrypts} the result with [wrap_key] ad algorithm [wrapper]. *) + + val unwrap_key : + Brr_webcrypto.Subtle_crypto.t -> + Brr_webcrypto.Crypto_key.Format.t -> + ('a, 'b) Tarray.t -> + wrap_key:Brr_webcrypto.Crypto_algo.t -> + wrapper:Brr_webcrypto.Crypto_algo.t -> + unwrapped:Brr_webcrypto.Crypto_algo.t -> + extractable:bool -> + usages:Brr_webcrypto.Crypto_key.Usage.t list -> + Brr_webcrypto.Crypto_algo.t + (** [unwrap_key s f b ~wrap_key ~wrapper ~unwrapped ~extractable ~usages] + is like {!import_key} but {{:https://developer.mozilla.org/en-US/docs/Web/API/SubtleCrypto/unwrapKey}unwraps} the wrapper of [b] made wtih [wrap_key] + and algorithm [wrapped]. *) +end diff --git a/lib_eio_brr/eio_brr_webgpu.ml b/lib_eio_brr/eio_brr_webgpu.ml new file mode 100644 index 000000000..f87fb9a24 --- /dev/null +++ b/lib_eio_brr/eio_brr_webgpu.ml @@ -0,0 +1,40 @@ +open Brr_webgpu + +module Gpu = struct + module Buffer = struct + let map_async ?size ?offset b mode = + Eio_fut.await_exn (Gpu.Buffer.map_async ?size ?offset b mode) + end + + module Shader_module = struct + let get_compilation_info m = + Eio_fut.await_exn (Gpu.Shader_module.get_compilation_info m) + end + + module Queue = struct + let on_submitted_work_done q = + Eio_fut.await_exn (Gpu.Queue.on_submitted_work_done q) + end + + module Device = struct + let lost d = Eio_fut.await_exn (Gpu.Device.lost d) + let pop_error_scope d = Eio_fut.await_exn (Gpu.Device.pop_error_scope d) + + let create_compute_pipeline_async d descr = + Eio_fut.await (Gpu.Device.create_compute_pipeline_async d descr) + + let create_render_pipeline_async d descr = + Eio_fut.await (Gpu.Device.create_render_pipeline_async d descr) + end + + module Adapter = struct + let request_device ?descriptor a = + Eio_fut.await_exn (Gpu.Adapter.request_device ?descriptor a) + + let request_adapter_info a ~unmask_hints = + Eio_fut.await_exn (Gpu.Adapter.request_adapter_info a ~unmask_hints) + end + + let request_adapter ?opts gpu = + Eio_fut.await_exn (Gpu.request_adapter ?opts gpu) +end diff --git a/lib_eio_brr/eio_brr_webgpu.mli b/lib_eio_brr/eio_brr_webgpu.mli new file mode 100644 index 000000000..7c438c4b4 --- /dev/null +++ b/lib_eio_brr/eio_brr_webgpu.mli @@ -0,0 +1,63 @@ +open Brr_webgpu + +(** WebGPU objects. *) +module Gpu : sig + (** GPU buffers. *) + module Buffer : sig + val map_async : + ?size:int -> ?offset:int -> Gpu.Buffer.t -> Gpu.Buffer.Map_mode.t -> unit + (** [map_async b] {{:https://developer.mozilla.org/en-US/docs/Web/API/GPUBuffer/mapAsync}maps} [b]. *) + end + + (** Shader modules. *) + module Shader_module : sig + val get_compilation_info : + Gpu.Shader_module.t -> Gpu.Shader_module.Compilation_info.t + (** [get_compilation_info sm] is the {{:https://developer.mozilla.org/en-US/docs/Web/API/GPUShaderModule/getCompilationInfo}compilation info} of [sm]. *) + end + + (** Queues. *) + module Queue : sig + val on_submitted_work_done : Gpu.Queue.t -> unit + (** [on_submitted_work_done q] resolves when submitted work on [q] {{:https://developer.mozilla.org/en-US/docs/Web/API/GPUQueue/onSubmittedWorkDone} + is done}. *) + end + + (** Devices. *) + module Device : sig + val lost : Gpu.Device.t -> Gpu.Device.Lost_info.t + (** [lost d] is the {{:https://developer.mozilla.org/en-US/docs/Web/API/GPUDevice/lost}lost} property of [d]. *) + + val pop_error_scope : Gpu.Device.t -> Gpu.Error.t option + (** [pop_error_scope] {{:https://developer.mozilla.org/en-US/docs/Web/API/GPUDevice/popErrorScope}pops} the last error scope. *) + + val create_compute_pipeline_async : + Gpu.Device.t -> + Gpu.Compute_pipeline.Descriptor.t -> + (Gpu.Compute_pipeline.t, Gpu.Pipeline_error.t) result + (** [create_compute_pipeline_async d descr] {{:https://developer.mozilla.org/en-US/docs/Web/API/GPUDevice/createComputePipelineAsync}creates} a compute pipeline on [d] according to [descr]. *) + + val create_render_pipeline_async : + Gpu.Device.t -> + Gpu.Render_pipeline.Descriptor.t -> + (Gpu.Compute_pipeline.t, Gpu.Pipeline_error.t) result + (** [create_render_pipeline_async d descr] {{:https://developer.mozilla.org/en-US/docs/Web/API/GPUDevice/createRenderPipelineAsync}creates} a render pipeline on [d] according to [descr]. *) + end + + (** Adapters. *) + module Adapter : sig + val request_device : + ?descriptor:Gpu.Device.Descriptor.t -> Gpu.Adapter.t -> Gpu.Device.t + (** [request_device a] + {{:https://developer.mozilla.org/en-US/docs/Web/API/GPUAdapter/requestDevice}requests} the device of [a]. *) + + val request_adapter_info : + Gpu.Adapter.t -> unmask_hints:Jstr.t list -> Gpu.Adapter.Info.t + (** [request_adapter_info a ~unmask_hints] {{:https://developer.mozilla.org/en-US/docs/Web/API/GPUAdapter/requestAdapterInfo}requests} the adapter info of [a]. *) + end + + val request_adapter : ?opts:Gpu.opts -> Gpu.t -> Gpu.Adapter.t option + (** [request_adapter gpu] + {{:https://developer.mozilla.org/en-US/docs/Web/API/GPU/requestAdapter} + requests} an adapter from [gpu]. *) +end diff --git a/lib_eio_brr/eio_brr_webmidi.ml b/lib_eio_brr/eio_brr_webmidi.ml new file mode 100644 index 000000000..095b17b68 --- /dev/null +++ b/lib_eio_brr/eio_brr_webmidi.ml @@ -0,0 +1,11 @@ +module Midi = struct + module Port = struct + let open' p = Eio_fut.await_exn (Brr_webmidi.Midi.Port.open' p) + let close p = Eio_fut.await_exn (Brr_webmidi.Midi.Port.close p) + end + + module Access = struct + let of_navigator ?opts n = + Eio_fut.await_exn (Brr_webmidi.Midi.Access.of_navigator ?opts n) + end +end diff --git a/lib_eio_brr/eio_brr_webmidi.mli b/lib_eio_brr/eio_brr_webmidi.mli new file mode 100644 index 000000000..18d698974 --- /dev/null +++ b/lib_eio_brr/eio_brr_webmidi.mli @@ -0,0 +1,20 @@ +(** Web MIDI. *) +module Midi : sig + (** MIDI port. *) + module Port : sig + val open' : Brr_webmidi.Midi.Port.t -> unit + (** [open' p] {{:https://developer.mozilla.org/en-US/docs/Web/API/MIDIPort/open}opens} the port. *) + + val close : Brr_webmidi.Midi.Port.t -> unit + (** [close p] {{:https://developer.mozilla.org/en-US/docs/Web/API/MIDIPort/close}closes} the port. *) + end + + (** MIDI access. *) + module Access : sig + val of_navigator : + ?opts:Brr_webmidi.Midi.Access.opts -> + Brr.Navigator.t -> + Brr_webmidi.Midi.Access.t + (** [of_navigator ?opts n] {{:https://developer.mozilla.org/en-US/docs/Web/API/Navigator/requestMIDIAccess}requests} a MIDI access object. *) + end +end diff --git a/lib_eio_brr/eio_brr_webworkers.ml b/lib_eio_brr/eio_brr_webworkers.ml new file mode 100644 index 000000000..839efb5d8 --- /dev/null +++ b/lib_eio_brr/eio_brr_webworkers.ml @@ -0,0 +1,71 @@ +open Brr_webworkers + +module Service_worker = struct + module Navigation_preload_manager = struct + let enable p = + Eio_fut.await_exn (Service_worker.Navigation_preload_manager.enable p) + + let disable p = + Eio_fut.await_exn (Service_worker.Navigation_preload_manager.disable p) + + let set_header_value p v = + Eio_fut.await_exn + (Service_worker.Navigation_preload_manager.set_header_value p v) + + let get_state p = + Eio_fut.await_exn (Service_worker.Navigation_preload_manager.get_state p) + end + + module Registration = struct + let update r = Eio_fut.await_exn (Service_worker.Registration.update r) + + let unregister r = + Eio_fut.await_exn (Service_worker.Registration.unregister r) + + let show_notification ?opts r title = + Eio_fut.await_exn + (Service_worker.Registration.show_notification ?opts r title) + + let get_notifications ?tag r = + Eio_fut.await_exn (Service_worker.Registration.get_notifications ?tag r) + end + + module Container = struct + let ready c = Eio_fut.await_exn (Service_worker.Container.ready c) + + let register ?register_opts c script_uri = + Eio_fut.await_exn + (Service_worker.Container.register ?register_opts c script_uri) + + let get_registration c url = + Eio_fut.await_exn (Service_worker.Container.get_registration c url) + + let get_registrations c = + Eio_fut.await_exn (Service_worker.Container.get_registrations c) + end + + module Client = struct + module Window = struct + let focus w = Eio_fut.await_exn (Service_worker.Client.Window.focus w) + + let navigate w uri = + Eio_fut.await_exn (Service_worker.Client.Window.navigate w uri) + end + end + + module Clients = struct + let get cs id = Eio_fut.await_exn (Service_worker.Clients.get cs id) + + let match_all ?query_opts cs = + Eio_fut.await_exn (Service_worker.Clients.match_all ?query_opts cs) + + let open_window cs uri = + Eio_fut.await_exn (Service_worker.Clients.open_window cs uri) + + let claim cs = Eio_fut.await_exn (Service_worker.Clients.claim cs) + end + + module G = struct + let skip_waiting () = Eio_fut.await_exn (Service_worker.G.skip_waiting ()) + end +end diff --git a/lib_eio_brr/eio_brr_webworkers.mli b/lib_eio_brr/eio_brr_webworkers.mli new file mode 100644 index 000000000..555729149 --- /dev/null +++ b/lib_eio_brr/eio_brr_webworkers.mli @@ -0,0 +1,132 @@ +(** Web and Service Worker APIs. *) + +open Brr_webworkers + +(** Service workers. + + See the {{:https://developer.mozilla.org/en-US/docs/Web/API/Service_Worker_API}Service Worker API}. + + The fetch caches and events are in {!Brr_io.Fetch}. *) +module Service_worker : sig + (** Ressources preloading *) + module Navigation_preload_manager : sig + val enable : Service_worker.Navigation_preload_manager.t -> unit + (** [enable p] {{:https://developer.mozilla.org/en-US/docs/Web/API/NavigationPreloadManager#Methods}enables} navigation preloading. *) + + val disable : Service_worker.Navigation_preload_manager.t -> unit + (** [disables p] {{:https://developer.mozilla.org/en-US/docs/Web/API/NavigationPreloadManager#Methods}disables} navigation preloading. *) + + val set_header_value : + Service_worker.Navigation_preload_manager.t -> Jstr.t -> unit + (** [set_header_value p v] {{:https://developer.mozilla.org/en-US/docs/Web/API/NavigationPreloadManager#Methods}sets} the value of the header. *) + + val get_state : Service_worker.Navigation_preload_manager.t -> bool * Jstr.t + (** [get_state p] {{:https://developer.mozilla.org/en-US/docs/Web/API/NavigationPreloadManager#Methods}indicates} whether preload is enabled and + the value of the header. *) + end + + (** Service registration objects. *) + module Registration : sig + val update : Service_worker.Registration.t -> unit + (** [update r] attempts to {{:https://developer.mozilla.org/en-US/docs/Web/API/ServiceWorkerRegistration/update}update} the service worker of [r]. *) + + val unregister : Service_worker.Registration.t -> bool + (** [unregister r] + {{:https://developer.mozilla.org/en-US/docs/Web/API/ServiceWorkerRegistration/unregister}unregisters} the service worker registration. This is [false] + if no registration was false. *) + + val show_notification : + ?opts:Brr_io.Notification.opts -> + Service_worker.Registration.t -> + Jstr.t -> + unit + (** [show_notification r title ~opts] + {{:https://developer.mozilla.org/en-US/docs/Web/API/ServiceWorkerRegistration/showNotification}displays} a notification with title [title] an options + [opts]. *) + + val get_notifications : + ?tag:Jstr.t -> Service_worker.Registration.t -> Brr_io.Notification.t list + (** [get_notifications r ~tag] are {{:https://developer.mozilla.org/en-US/docs/Web/API/ServiceWorkerRegistration/getNotifications}notifications} created via [r] and tagged with [tag] (or all of them if unspecified). *) + end + + (** Service worker containers. *) + module Container : sig + val ready : Service_worker.Container.t -> Service_worker.Registration.t + (** [ready c] is a future that resolves when a service worker is + {{:https://developer.mozilla.org/en-US/docs/Web/API/ServiceWorkerContainer/ready}active}. *) + + val register : + ?register_opts:Service_worker.Container.register_opts -> + Service_worker.Container.t -> + Jstr.t -> + Service_worker.Registration.t + (** [register c script_uri ~register_opts] {{:https://developer.mozilla.org/en-US/docs/Web/API/ServiceWorkerContainer/register}creates or updates} a + registration with [script_url]. *) + + val get_registration : + Service_worker.Container.t -> + Jstr.t option -> + Service_worker.Registration.t option + (** [get_registration c url] is the {{:https://developer.mozilla.org/en-US/docs/Web/API/ServiceWorkerContainer/getRegistration}registration} for + [url] (if any). *) + + val get_registrations : + Service_worker.Container.t -> Service_worker.Registration.t list + (** [get_registrations c] are {{:https://developer.mozilla.org/en-US/docs/Web/API/ServiceWorkerContainer/getRegistrations}all} the registration fo [c]. *) + end + + (** {1:worker_funs Service worker context} + + These APIs are used by the service worker. *) + + (** Client objects. *) + module Client : sig + (** {1:window Window clients} *) + + (** Window clients. *) + module Window : sig + val focus : + Service_worker.Client.Window.t -> Service_worker.Client.Window.t + (** [focus w] {{:https://developer.mozilla.org/en-US/docs/Web/API/WindowClient/focus}focuses} [w]. *) + + val navigate : + Service_worker.Client.Window.t -> + Jstr.t -> + Service_worker.Client.Window.t + (** [navigate w uri] {{:https://developer.mozilla.org/en-US/docs/Web/API/WindowClient/navigate}loads} [uri] in [w]. *) + end + end + + (** Clients objects. *) + module Clients : sig + val get : + Service_worker.Clients.t -> Jstr.t -> Service_worker.Client.t option + (** [get cs id] is a client {{:https://developer.mozilla.org/en-US/docs/Web/API/Clients/get}matching} [id] (if any). *) + + val match_all : + ?query_opts:Service_worker.Clients.query_opts -> + Service_worker.Clients.t -> + Service_worker.Client.t list + (** [match_all cs ~query_opts] are clients {{:https://developer.mozilla.org/en-US/docs/Web/API/Clients/matchAll}matching} [query_opts]. *) + + val open_window : + Service_worker.Clients.t -> + Jstr.t -> + Service_worker.Client.Window.t option + (** [open_window cs uri] {{:https://developer.mozilla.org/en-US/docs/Web/API/Clients/openWindow}opens} a window on [uri]. *) + + val claim : Service_worker.Clients.t -> unit + (** [claim cs] + {{:https://developer.mozilla.org/en-US/docs/Web/API/Clients/claim}sets} + the calling service worker as a controller for all clients in + its scope. *) + end + + (** Service worker global properties and functions. *) + module G : sig + val skip_waiting : unit -> unit + (** [skip_waiting ()] + {{:https://developer.mozilla.org/en-US/docs/Web/API/ServiceWorkerGlobalScope/skipWaiting}forces} the waiting service to become + the active service worker. *) + end +end diff --git a/lib_eio_brr/eio_fut.ml b/lib_eio_brr/eio_fut.ml new file mode 100644 index 000000000..fce8c95d9 --- /dev/null +++ b/lib_eio_brr/eio_fut.ml @@ -0,0 +1,23 @@ +let await ?abort fut = + Eio_js_backend.await + ~setup:(fun ~resolve ~reject:_ -> Fut.await fut resolve) + ~cancel:(fun () -> Option.iter (fun f -> f ()) abort) + +let await_exn ?abort fut = + let setup ~resolve ~reject = + Fut.await fut (fun res -> + match res with Ok v -> resolve v | Error e -> reject (Jv.Error e)) + in + Eio_js_backend.await ~setup ~cancel:(fun () -> + Option.iter (fun f -> f ()) abort) + +let make ~sw f = + let fut, set = Fut.create () in + Eio.Fiber.fork ~sw (fun () -> set (f ())); + fut + +let make_exn ~sw f = + let fut, set = Fut.create () in + Eio.Fiber.fork ~sw (fun () -> + try set (Ok (f ())) with Jv.Error err -> set (Error err)); + fut diff --git a/lib_eio_brr/eio_fut.mli b/lib_eio_brr/eio_fut.mli new file mode 100644 index 000000000..0f39d237a --- /dev/null +++ b/lib_eio_brr/eio_fut.mli @@ -0,0 +1,21 @@ +val await : ?abort:(unit -> unit) -> 'a Fut.t -> 'a +(** [await ?abort f] waits for the completion of future [f] and + returns its value. The optional [abort] function is called when + the fiber is cancelled. *) + +val await_exn : ?abort:(unit -> unit) -> 'a Fut.or_error -> 'a +(** [await ?abort f] waits for the completion of future [f] and + returns its value. An exception is raised in case of a JavaScript + error. The optional [abort] function is called when the fiber is + cancelled. *) + +val make : sw:Eio.Switch.t -> (unit -> 'a) -> 'a Fut.t +(** [make ~sw fn] runs [fn] in a new fiber (attached to [sw]) and + returns a future whose value is the return value of the + function. *) + +val make_exn : sw:Eio.Switch.t -> (unit -> 'a) -> 'a Fut.or_error +(** [make ~sw fn] runs [fn] in a new fiber (attached to [sw]) and + returns a future whose value is either the return value of the + function or a JavaScript error if the functions fails with a + JavaScript exception. *) diff --git a/lib_eio_js_backend/dune b/lib_eio_js_backend/dune new file mode 100644 index 000000000..aef0be01e --- /dev/null +++ b/lib_eio_js_backend/dune @@ -0,0 +1,5 @@ +(library + (name eio_js_backend) + (public_name eio_js_backend) + (modes byte) + (libraries eio)) diff --git a/lib_eio_js_backend/eio_js_backend.ml b/lib_eio_js_backend/eio_js_backend.ml new file mode 100644 index 000000000..32f0b7602 --- /dev/null +++ b/lib_eio_js_backend/eio_js_backend.ml @@ -0,0 +1,190 @@ +(* + * Copyright (C) 2021-2023 Thomas Leonard + * Copyright (C) 2023 Patrick Ferris + * Copyright (C) 2024 Jérôme Vouillon + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +(* The scheduler executes eagerly the active fibers until the run + queue gets empty. It becomes active when the function [start] is + called or when a fiber is resumed. + + There is no protection against busy yielding. We expect the + programs to perform some computations in response to external + events for some finite amount of time and to be otherwise idle. +*) + +module Fiber_context = Eio.Private.Fiber_context +module Trace = Eio.Private.Trace + +module Run_queue : sig + type 'a t + (* A queue that supports pushing to the head of the queue *) + + val create : unit -> 'a t + + val push : 'a t -> 'a -> unit + (** [push q v] pushes a new item [v] to the back of the queue [q] *) + + val push_head : 'a t -> 'a -> unit + (** [push_head q v] pushes a new item [v] to the head of the queue [q] *) + + val pop : 'a t -> 'a option + (** [pop q] pops the next item of the queue if available. *) +end = struct + type 'a t = 'a Lwt_dllist.t + + let create () = Lwt_dllist.create () + let push q v = ignore (Lwt_dllist.add_r v q : 'a Lwt_dllist.node) + let push_head q v = ignore (Lwt_dllist.add_l v q : 'a Lwt_dllist.node) + let pop q = Lwt_dllist.take_opt_l q +end + +type suspend = Suspend + +module Suspended = struct + type 'a t = { + fiber : Eio.Private.Fiber_context.t; + k : ('a, suspend) Effect.Deep.continuation; + } + + let tid t = Eio.Private.Fiber_context.tid t.fiber + + let continue t v = + Trace.fiber (tid t); + Effect.Deep.continue t.k v + + let discontinue t ex = + Trace.fiber (tid t); + Effect.Deep.discontinue t.k ex +end + +module Scheduler : sig + val activate : (unit -> suspend) -> unit + val next : unit -> suspend + val enqueue_thread : 'a Suspended.t -> 'a -> unit + val enqueue_failed_thread : 'a Suspended.t -> exn -> unit + val enqueue_at_head : 'a Suspended.t -> 'a -> unit +end = struct + let run_queue = Run_queue.create () + let active = ref false + + let resume fn = + assert (not !active); + active := true; + let Suspend = fn () in + active := false + + let next () = + assert !active; + match Run_queue.pop run_queue with Some fn -> fn () | None -> Suspend + + let resume_if_needed () = if not !active then resume next + + let enqueue_thread k v = + Run_queue.push run_queue (fun () -> Suspended.continue k v); + resume_if_needed () + + let enqueue_failed_thread k v = + Run_queue.push run_queue (fun () -> Suspended.discontinue k v); + resume_if_needed () + + let enqueue_at_head k v = + assert !active; + Run_queue.push_head run_queue (fun () -> Suspended.continue k v) + + let activate fn = if !active then Run_queue.push run_queue fn else resume fn +end + +let default_uncaught_exception_handler exn raw_backtrace = + Printexc.default_uncaught_exception_handler exn raw_backtrace; + exit 2 + +let uncaught_exception_handler = ref default_uncaught_exception_handler +let set_uncaught_exception_handler fn = uncaught_exception_handler := fn + +type _ Effect.t += Enter : ('a Suspended.t -> unit) -> 'a Effect.t + +let enter fn = Effect.perform (Enter fn) + +let start main = + let rec fork ~new_fiber:fiber fn = + Effect.Deep.match_with fn () + { + retc = + (fun () -> + Fiber_context.destroy fiber; + Scheduler.next ()); + exnc = + (fun ex -> + let bt = Printexc.get_raw_backtrace () in + Fiber_context.destroy fiber; + !uncaught_exception_handler ex bt; + Scheduler.next ()); + effc = + (fun (type a) (e : a Effect.t) : + ((a, suspend) Effect.Deep.continuation -> suspend) option -> + match e with + | Eio.Private.Effects.Suspend f -> + Some + (fun k -> + let k = { Suspended.k; fiber } in + f fiber (function + | Ok v -> Scheduler.enqueue_thread k v + | Error ex -> Scheduler.enqueue_failed_thread k ex); + Scheduler.next ()) + | Enter fn -> + Some + (fun k -> + match Fiber_context.get_error fiber with + | Some exn -> Effect.Deep.discontinue k exn + | None -> + fn { Suspended.k; fiber }; + Scheduler.next ()) + | Eio.Private.Effects.Fork (new_fiber, f) -> + Some + (fun k -> + let k = { Suspended.k; fiber } in + Scheduler.enqueue_at_head k (); + fork ~new_fiber f) + | Eio.Private.Effects.Get_context -> + Some (fun k -> Effect.Deep.continue k fiber) + | _ -> None); + } + in + let new_fiber = Fiber_context.make_root () in + Scheduler.activate (fun () -> fork ~new_fiber main) + +let await ~setup ~cancel = + enter @@ fun k -> + let resumed = ref false in + let resolve v = + if not !resumed then ( + resumed := true; + Fiber_context.clear_cancel_fn k.fiber; + Scheduler.enqueue_thread k v) + in + let reject exn = + if not !resumed then ( + resumed := true; + Fiber_context.clear_cancel_fn k.fiber; + Scheduler.enqueue_failed_thread k exn) + in + Fiber_context.set_cancel_fn k.fiber reject; + try + let id = setup ~resolve ~reject in + Fiber_context.set_cancel_fn k.fiber (fun exn -> + cancel id; + reject exn) + with exn -> reject exn diff --git a/lib_eio_js_backend/eio_js_backend.mli b/lib_eio_js_backend/eio_js_backend.mli new file mode 100644 index 000000000..073542e63 --- /dev/null +++ b/lib_eio_js_backend/eio_js_backend.mli @@ -0,0 +1,34 @@ +(** Eio backend for JavaScript environments. + + You will normally not use this module directly. + Instead, use {!Eio_brr.start} or {!Js_of_ocaml_eio.Eio_js.start} and then use the API in the {!Eio} module. +*) + +val start : (unit -> unit) -> unit +(** [start fn] executes function [fn] in an environment where Eio + effects can be performed. The function is executed asynchronously: + [start fn] returns when all fibers are suspended, without waiting + for them to complete. + + If [fn ()] raises an exception, the exception is passed to a + handler that by default outputs the exception to [stderr] and + exits the program (when this makes sense, that is, in particular, + not in a browser environment). + + You should not expect effect handlers set-up outside of [start fn] + to be available during the execution of function [fn]. +*) + +val await : + setup:(resolve:('a -> unit) -> reject:(exn -> unit) -> 'handle) -> + cancel:('handle -> unit) -> + 'a +(** [await setup cancel] suspends the current fiber and calls + [setup resolve reject]. The fiber is resumed normally with some + value [v] when [resolve v] is called. It is resumed with exception + [exn] when [reject exn] is called. If the fiber is cancelled, + function [cancel] is called. *) + +val set_uncaught_exception_handler : + (exn -> Printexc.raw_backtrace -> unit) -> unit +(** [start fn] registers [fn] as the handler for uncaught exceptions. *) diff --git a/lib_eio_js_backend/tests/condition.md b/lib_eio_js_backend/tests/condition.md new file mode 100644 index 000000000..9d169c3ec --- /dev/null +++ b/lib_eio_js_backend/tests/condition.md @@ -0,0 +1,324 @@ +# Setting up the environment + +```ocaml +# #require "eio_js_backend";; +# Eio_js_backend.set_uncaught_exception_handler + (fun exn _ -> Format.eprintf "@[Exception:@ %s.@]@." (Printexc.to_string exn)) +- : unit = () +``` + +```ocaml +open Eio.Std + +module C = Eio.Condition +``` + +# Test cases + +Simple case: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + let condition = C.create () in + Fiber.both + (fun () -> + traceln "1: wait for condition"; + C.await_no_mutex condition; + traceln "1: finished") + (fun () -> + traceln "2: broadcast condition"; + C.broadcast condition; + traceln "2: finished");; ++1: wait for condition ++2: broadcast condition ++2: finished ++1: finished +- : unit = () +``` + +Broadcast when no one is waiting doesn't block: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + let condition = C.create () in + traceln "broadcast condition"; + C.broadcast condition; + traceln "finished";; ++broadcast condition ++finished +- : unit = () +``` + +Broadcast wakes all waiters at once: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + let condition = C.create () in + Fiber.all [ + (fun () -> + traceln "1: wait for condition"; + C.await_no_mutex condition; + traceln "1: finished"); + (fun () -> + traceln "2: wait for condition"; + C.await_no_mutex condition; + traceln "2: finished"); + (fun () -> + traceln "3: broadcast condition"; + C.broadcast condition; + traceln "3: finished") + ];; ++1: wait for condition ++2: wait for condition ++3: broadcast condition ++3: finished ++1: finished ++2: finished +- : unit = () +``` + +## Typical single-domain use + +```ocaml +let x = ref 0 +let cond = Eio.Condition.create () + +let set value = + x := value; + Eio.Condition.broadcast cond + +let await p = + (* Warning: only safe within a single-domain, and if [p] doesn't switch fibers! *) + while not (p !x) do + Eio.Condition.await_no_mutex cond + done +``` + +```ocaml +# Eio_js_backend.start @@ fun () -> + Fiber.both + (fun () -> + traceln "x = %d" !x; + await ((=) 42); + traceln "x = %d" !x + ) + (fun () -> + set 5; + Fiber.yield (); + set 7; + set 42; + );; ++x = 0 ++x = 42 +- : unit = () +``` + +Cancellation while waiting: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Fiber.first + (fun () -> + await ((=) 0); + assert false; + ) + (fun () -> ()); + Fiber.both + (fun () -> + traceln "x = %d" !x; + await ((=) 0); + traceln "x = %d" !x + ) + (fun () -> + set 5; + Fiber.yield (); + set 0; + );; ++x = 42 ++x = 0 +- : unit = () +``` + +## Use with mutex + +```ocaml +let x = ref 0 +let cond = Eio.Condition.create () +let mutex = Eio.Mutex.create () + +let set value = + Eio.Mutex.use_rw ~protect:false mutex (fun () -> x := value); + Eio.Condition.broadcast cond + +let await p = + Eio.Mutex.use_ro mutex (fun () -> + while not (p !x) do + Eio.Condition.await cond mutex + done + ) +``` + +```ocaml +# Eio_js_backend.start @@ fun () -> + Fiber.both + (fun () -> + traceln "x = %d" !x; + await ((=) 42); + traceln "x = %d" !x + ) + (fun () -> + set 5; + Fiber.yield (); + set 7; + set 42; + );; ++x = 0 ++x = 42 +- : unit = () +``` + +Cancellation while waiting: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Fiber.first + (fun () -> + await ((=) 0); + assert false; + ) + (fun () -> ()); + Fiber.both + (fun () -> + traceln "x = %d" !x; + await ((=) 0); + traceln "x = %d" !x + ) + (fun () -> + set 5; + Fiber.yield (); + set 0; + );; ++x = 42 ++x = 0 +- : unit = () +``` + +### Cancelling while the mutex is held + +`await` must always re-acquire the lock, and that lock operation must be non-cancellable: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork ~sw + (fun () -> + traceln "Forked fiber locking"; + Eio.Mutex.lock mutex; + try + Eio.Condition.await cond mutex; + assert false; + with Eio.Cancel.Cancelled _ as ex -> + traceln "Forked fiber unlocking"; + Eio.Mutex.unlock mutex; + raise ex + ); + Eio.Cancel.protect + (fun () -> + traceln "Main fiber locking"; + Eio.Mutex.lock mutex; + Switch.fail sw (Failure "Simulated error"); + Fiber.yield (); + traceln "Main fiber unlocking"; + Eio.Mutex.unlock mutex; + ) ++Forked fiber locking ++Main fiber locking ++Main fiber unlocking ++Forked fiber unlocking +Exception: Failure("Simulated error"). +- : unit = () +``` + +### Looping + +```ocaml +# Eio_js_backend.start @@ fun () -> + let cond = Eio.Condition.create () in + let x = ref 0 in + let set v = + traceln "setting x=%d" v; + x := v; Eio.Condition.broadcast cond + in + Fiber.both + (fun () -> + Eio.Condition.loop_no_mutex cond (fun () -> + traceln "Checking x..."; + Fiber.yield (); + let seen = !x in + traceln "Saw x = %d" seen; + if seen = 3 then (traceln "Finished"; Some ()) + else None + ) + ) + (fun () -> + set 1; Fiber.yield (); + set 2; Fiber.yield (); + set 3; Fiber.yield (); + set 4; Fiber.yield (); + );; ++Checking x... ++setting x=1 ++Saw x = 1 ++setting x=2 ++Checking x... ++setting x=3 ++Saw x = 3 ++Finished ++setting x=4 +- : unit = () +``` + +Cancelling: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let cond = Eio.Condition.create () in + Fiber.both + (fun () -> Eio.Condition.loop_no_mutex cond (fun () -> traceln "Checking"; None)) + (fun () -> failwith "Simulated error");; ++Checking +Exception: Failure("Simulated error"). +- : unit = () +``` + +Cancelling after succeeding: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let cond = Eio.Condition.create () in + Fiber.both + (fun () -> Eio.Condition.loop_no_mutex cond (fun () -> traceln "Checking"; None)) + (fun () -> + traceln "Broadcasting"; + Eio.Condition.broadcast cond; + failwith "Simulated error" + );; ++Checking ++Broadcasting ++Checking +Exception: Failure("Simulated error"). +- : unit = () +``` + +User function raises: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let cond = Eio.Condition.create () in + Eio.Condition.loop_no_mutex cond (fun () -> Fiber.yield (); failwith "Simulated failure");; +Exception: Failure("Simulated failure"). +- : unit = () +``` diff --git a/lib_eio_js_backend/tests/dune b/lib_eio_js_backend/tests/dune new file mode 100644 index 000000000..b7dd48a0e --- /dev/null +++ b/lib_eio_js_backend/tests/dune @@ -0,0 +1,4 @@ +(mdx + (package eio_js_backend) + (deps + (package eio_js_backend))) diff --git a/lib_eio_js_backend/tests/exn.md b/lib_eio_js_backend/tests/exn.md new file mode 100644 index 000000000..8cc25eb52 --- /dev/null +++ b/lib_eio_js_backend/tests/exn.md @@ -0,0 +1,93 @@ +# Setting up the environment + +```ocaml +# #require "eio_js_backend";; +``` + +Adjust this to test backtrace printing: +```ocaml +let () = Printexc.record_backtrace false +``` + +```ocaml +type Eio.Exn.Backend.t += Simulated_failure +let () = Eio.Exn.Backend.register_pp (fun f -> function + | Simulated_failure -> Fmt.string f "Simulated_failure"; true + | _ -> false + ) +``` + +```ocaml +let non_io a = + try failwith a + with ex -> ex, Printexc.get_raw_backtrace () + +let not_found = + try raise @@ Eio.Fs.err (Not_found Simulated_failure) + with ex -> + let bt = Printexc.get_raw_backtrace () in + let ex = Eio.Exn.add_context ex "opening file 'foo'" in + ex, bt + +let denied = + try raise @@ Eio.Fs.err (Permission_denied Simulated_failure) + with ex -> + let bt = Printexc.get_raw_backtrace () in + let ex = Eio.Exn.add_context ex "saving file 'bar'" in + ex, bt + +let combine a b = + fst @@ Eio.Exn.combine a b +``` + +## Combining exceptions + +Combining regular exceptions: + +```ocaml +# raise @@ combine (non_io "a") (non_io "b");; +Exception: Multiple exceptions: +- Failure("a") +- Failure("b") +``` + +An IO error and a regular exception becomes a regular (non-IO) multiple exception: + +```ocaml +# raise @@ combine (non_io "a") not_found;; +Exception: +Multiple exceptions: +- Failure("a") +- Eio.Io Fs Not_found Simulated_failure, + opening file 'foo' +``` + +Combining IO exceptions produces another IO exception, +so that if you want to e.g. log all IO errors and continue then that still works: + +```ocaml +# Fmt.pr "%a@." Eio.Exn.pp (combine denied not_found);; +Eio.Io Multiple_io +- Fs Permission_denied Simulated_failure, saving file 'bar' +- Fs Not_found Simulated_failure, opening file 'foo' +- : unit = () +``` + +They form a tree, because the context information may be useful too: + +```ocaml +let combined = + let e = Eio.Exn.combine denied not_found in + let ex = Eio.Exn.add_context (fst e) "processing request" in + ex, snd e +``` + +```ocaml +# Fmt.pr "%a@." Eio.Exn.pp (combine combined not_found);; +Eio.Io Multiple_io +- Multiple_io + - Fs Permission_denied Simulated_failure, saving file 'bar' + - Fs Not_found Simulated_failure, opening file 'foo', processing request +- Fs Not_found Simulated_failure, opening file 'foo' +- : unit = () +``` diff --git a/lib_eio_js_backend/tests/fiber.md b/lib_eio_js_backend/tests/fiber.md new file mode 100644 index 000000000..0528d0e61 --- /dev/null +++ b/lib_eio_js_backend/tests/fiber.md @@ -0,0 +1,1002 @@ +# Setting up the environment + +```ocaml +# #require "eio_js_backend";; +# Eio_js_backend.set_uncaught_exception_handler + (fun exn _ -> Format.eprintf "@[Exception:@ %s.@]@." (Printexc.to_string exn)) +- : unit = () +``` + +```ocaml +open Eio.Std + +let run fn = + Eio_js_backend.start @@ fun _ -> + traceln "%s" (fn ()) +``` + +# Fiber.first + +First finishes, second is cancelled: + +```ocaml +# run @@ fun () -> + let p, r = Promise.create () in + Fiber.first + (fun () -> "a") + (fun () -> Promise.await p);; ++a +- : unit = () +``` + +Second finishes, first is cancelled: + +```ocaml +# run @@ fun () -> + let p, r = Promise.create () in + Fiber.first + (fun () -> Promise.await p) + (fun () -> "b");; ++b +- : unit = () +``` + +If both succeed and no ~combine, we pick the first one by default: + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> "a") + (fun () -> "b");; ++a +- : unit = () +``` + +If both succeed we let ~combine decide: + +```ocaml +# run @@ fun () -> + Fiber.first ~combine:(fun _ x -> x) + (fun () -> "a") + (fun () -> "b");; ++b +- : unit = () +``` + +It allows for safe Stream.take races (both): + +```ocaml +# run @@ fun () -> + let stream = Eio.Stream.create 1 in + Fiber.first ~combine:(fun x y -> x ^ y) + (fun () -> + Fiber.yield (); + Eio.Stream.add stream "b"; + "a" + ) + (fun () -> Eio.Stream.take stream);; ++ab +- : unit = () +``` + +It allows for safe Stream.take races (f is first): + +```ocaml +# run @@ fun () -> + let stream = Eio.Stream.create 1 in + let out = + Fiber.first ~combine:(fun x y -> x ^ y) + (fun () -> + Eio.Stream.add stream "b"; + Fiber.yield (); + "a" + ) + (fun () -> + Fiber.yield (); + Eio.Stream.take stream) + in + out ^ Int.to_string (Eio.Stream.length stream);; ++a1 +- : unit = () +``` + +It allows for safe Stream.take races (g is first): + +```ocaml +# run @@ fun () -> + let stream = Eio.Stream.create 1 in + let out = + Fiber.first ~combine:(fun x y -> x ^ y) + (fun () -> + Eio.Stream.add stream "b"; + Fiber.yield (); + "a" + ) + (fun () -> Eio.Stream.take stream) + in + out ^ Int.to_string (Eio.Stream.length stream);; ++b0 +- : unit = () +``` + +One crashes - report it: + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> "a") + (fun () -> failwith "b crashed");; +Exception: Failure("b crashed"). +- : unit = () +``` + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> failwith "a crashed") + (fun () -> "b");; +Exception: Failure("a crashed"). +- : unit = () +``` + +Both crash - report both: + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> failwith "a crashed") + (fun () -> failwith "b crashed");; +Exception: +Multiple exceptions: +- Failure("a crashed") +- Failure("b crashed"). +- : unit = () +``` + +Cancelled before it can crash: + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> "a") + (fun () -> Fiber.yield (); failwith "b crashed");; ++a +- : unit = () +``` + +One claims to be cancelled (for some reason other than the other fiber finishing): + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> raise (Eio.Cancel.Cancelled (Failure "cancel-a"))) + (fun () -> "b");; +Exception: Cancelled: Failure("cancel-a"). +- : unit = () +``` + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> Fiber.yield (); "a") + (fun () -> raise (Eio.Cancel.Cancelled (Failure "cancel-b")));; +Exception: Cancelled: Failure("cancel-b"). +- : unit = () +``` + +Cancelled from parent: + +```ocaml +# run @@ fun () -> + let p, r = Promise.create () in + Fiber.both + (fun () -> + failwith @@ Fiber.first + (fun () -> Promise.await p) + (fun () -> Promise.await p) + ) + (fun () -> failwith "Parent cancel"); + "not-reached";; +Exception: Failure("Parent cancel"). +- : unit = () +``` + +Cancelled from parent while already cancelling: + +```ocaml +# run @@ fun () -> + Fiber.both + (fun () -> + let _ = Fiber.first + (fun () -> "a") + (fun () -> Fiber.yield (); failwith "cancel-b") + in + traceln "Parent cancel failed" + ) + (fun () -> traceln "Cancelling parent"; failwith "Parent cancel"); + "not-reached";; ++Cancelling parent +Exception: Failure("Parent cancel"). +- : unit = () +``` + +Cancelling in a sub-switch. We see the exception as `Cancelled Exit` when we're being asked to cancel, +but just as plain `Exit` after we leave the context in which the cancellation started: + +```ocaml +# run @@ fun () -> + let p, r = Promise.create () in + Fiber.both + (fun () -> + try + Switch.run (fun _ -> + try Promise.await p + with ex -> traceln "Nested exception: %a" Fmt.exn ex; raise ex + ) + with ex -> traceln "Parent exception: %a" Fmt.exn ex; raise ex + ) + (fun () -> raise Exit); + failwith "not-reached";; ++Nested exception: Cancelled: Stdlib.Exit ++Parent exception: Cancelled: Stdlib.Exit +Exception: Stdlib.Exit. +- : unit = () +``` + +# Fiber.pair + +```ocaml +# run @@ fun () -> + let x, y = Fiber.pair (fun () -> "a") (fun () -> "b") in + x ^ y;; ++ab +- : unit = () +``` + +# Fiber.all + +```ocaml +# run @@ fun () -> + Fiber.all []; + Fiber.all (List.init 3 (fun x () -> traceln "fiber %d" x)); + "done";; ++fiber 0 ++fiber 1 ++fiber 2 ++done +- : unit = () +``` + +# Fiber.any + +```ocaml +# run @@ fun () -> + string_of_int @@ + Fiber.any (List.init 3 (fun x () -> traceln "%d" x; Fiber.yield (); x));; ++0 ++1 ++2 ++0 +- : unit = () +``` + +`Fiber.any` with combine collects all results: + +```ocaml +# run @@ fun () -> + Fiber.any + ~combine:(fun x y -> x @ y) + (List.init 3 (fun x () -> traceln "%d" x; [x])) + |> Fmt.(str "%a" (Dump.list int));; ++0 ++1 ++2 ++[0; 1; 2] +- : unit = () +``` + +# Fiber.n_any + +`Fiber.n_any` behaves just like `Fiber.any` when there's only one result: + +```ocaml +# run @@ fun () -> + Fiber.n_any (List.init 3 (fun x () -> traceln "%d" x; Fiber.yield (); x)) + |> Fmt.(str "%a" (Dump.list int));; ++0 ++1 ++2 ++[0] +- : unit = () +``` + +`Fiber.n_any` collects all results: + +```ocaml +# run @@ fun () -> + (Fiber.n_any (List.init 4 (fun x () -> + traceln "%d" x; + if x = 1 then Fiber.yield (); + x + ))) + |> Fmt.(str "%a" (Dump.list int));; ++0 ++1 ++2 ++3 ++[0; 2; 3] +- : unit = () +``` + +# Fiber.await_cancel + +```ocaml +# run @@ fun () -> + Fiber.both + (fun () -> + try Fiber.await_cancel () + with Eio.Cancel.Cancelled _ as ex -> + traceln "Caught: %a" Fmt.exn ex; + raise ex + ) + (fun () -> failwith "simulated error"); + "not reached";; ++Caught: Cancelled: Failure("simulated error") +Exception: Failure("simulated error"). +- : unit = () +``` + +# Fiber.fork_promise + +`Fiber.fork_promise ~sw` inherits the cancellation context from `sw`, not from the current fiber: + +```ocaml +# run @@ fun () -> + let switch = ref None in + Fiber.both + (fun () -> + Switch.run @@ fun sw -> + switch := Some sw; + Fiber.await_cancel () + ) + (fun () -> + let sw = Option.get !switch in + Eio.Cancel.protect @@ fun () -> + let child = Fiber.fork_promise ~sw (fun () -> + traceln "Forked child"; + Fiber.await_cancel () + ) in + Switch.fail sw Exit; + Promise.await_exn child + ); + "not reached";; ++Forked child +Exception: Stdlib.Exit. +- : unit = () +``` + +# Scheduling order + +Forking runs the child first, and puts the calling fiber at the head of the run-queue. + +```ocaml +# run @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork ~sw (fun () -> traceln "1st child runs"; Fiber.yield (); traceln "Queued work"); + Fiber.fork ~sw (fun () -> traceln "2nd child runs immediately"); + traceln "Caller runs before queued work"; + "ok";; ++1st child runs ++2nd child runs immediately ++Caller runs before queued work ++Queued work ++ok +- : unit = () +``` + +Same with `both`: + +```ocaml +# run @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork ~sw (fun () -> traceln "Enqueuing work for later"; Fiber.yield (); traceln "Queued work"); + Fiber.both + (fun () -> traceln "1st branch") + (fun () -> traceln "2nd branch"); + "ok";; ++Enqueuing work for later ++1st branch ++2nd branch ++Queued work ++ok +- : unit = () +``` + +Same with `first`: + +```ocaml +# run @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork ~sw (fun () -> traceln "Enqueuing work for later"; Fiber.yield (); traceln "Queued work"); + Fiber.first + (fun () -> traceln "1st branch") + (fun () -> traceln "2nd branch"); + "ok";; ++Enqueuing work for later ++1st branch ++2nd branch ++Queued work ++ok +- : unit = () +``` + +# Forking while cancelled + +```ocaml +# run @@ fun () -> + Fiber.first + (fun () -> failwith "Simulated error") + (fun () -> + Fiber.both + (fun () -> traceln "Not reached") + (fun () -> traceln "Not reached"); + assert false + );; +Exception: Failure("Simulated error"). +- : unit = () +``` + +# Concurrent list operations + +```ocaml +let process fn x = + traceln "Start %d" x; + Fiber.yield (); + let y = fn x in + traceln "Finished %d" x; + y + +let is_even x = (x land 1 = 0) + +let string_even x = + if is_even x then Some (string_of_int x) + else None + +let crash_on_three x = + if x = 3 then failwith "Simulated error" + else string_even x +``` + +```ocaml +# Eio_js_backend.start @@ fun () -> + Fiber.List.filter (process is_even) [1; 2; 3; 4] + |> traceln "%a" Fmt.(Dump.list int);; ++Start 1 ++Start 2 ++Start 3 ++Start 4 ++Finished 1 ++Finished 2 ++Finished 3 ++Finished 4 ++[2; 4] +- : unit = () +``` + +```ocaml +# Eio_js_backend.start @@ fun () -> + Fiber.List.map (process string_even) [1; 2; 3; 4] + |> traceln "%a" Fmt.Dump.(list (option string));; ++Start 1 ++Start 2 ++Start 3 ++Start 4 ++Finished 1 ++Finished 2 ++Finished 3 ++Finished 4 ++[None; Some "2"; None; Some "4"] +- : unit = () +``` + +```ocaml +# Eio_js_backend.start @@ fun () -> + Fiber.List.filter_map (process string_even) [1; 2; 3; 4] + |> traceln "%a" Fmt.Dump.(list string);; ++Start 1 ++Start 2 ++Start 3 ++Start 4 ++Finished 1 ++Finished 2 ++Finished 3 ++Finished 4 ++["2"; "4"] +- : unit = () +``` + +If any fiber raises, everything is cancelled: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Fiber.List.filter_map (process crash_on_three) [1; 2; 3; 4] + |> traceln "%a" Fmt.Dump.(list string);; ++Start 1 ++Start 2 ++Start 3 ++Start 4 ++Finished 1 ++Finished 2 +Exception: Failure("Simulated error"). +- : unit = () +``` + +The number of concurrent fibers can be limited: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let ps = Array.init 4 (fun _ -> Promise.create ()) in + let await i = Promise.await (fst ps.(i)) in + let finish i = Promise.resolve (snd (ps.(i))) in + Fiber.both + (fun () -> + Fiber.List.map ~max_fibers:2 (process await) (List.init 4 Fun.id) + |> traceln "%a" Fmt.(Dump.list string) + ) + (fun () -> + finish 1 "one"; + Fiber.yield (); + finish 2 "two"; + Fiber.yield (); Fiber.yield (); + finish 0 "zero"; + Fiber.yield (); Fiber.yield (); + finish 3 "three"; + );; ++Start 0 ++Start 1 ++Finished 1 ++Start 2 ++Finished 2 ++Start 3 ++Finished 0 ++Finished 3 ++[zero; one; two; three] +- : unit = () +``` + +Handling exceptions while waiting for a free fiber: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let ps = Array.init 2 (fun _ -> Promise.create ()) in + let await i = Promise.await_exn (fst ps.(i)) in + let finish i = Promise.resolve (snd (ps.(i))) in + Fiber.both + (fun () -> + Fiber.List.map ~max_fibers:1 (process await) (List.init 2 Fun.id) + |> traceln "%a" Fmt.(Dump.list string) + ) + (fun () -> + Fiber.yield (); + finish 0 (Error (Failure "Simulated error")) + );; ++Start 0 +Exception: Failure("Simulated error"). +- : unit = () +``` + +Simple iteration: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let ps = Array.init 4 (fun _ -> Promise.create ()) in + let await i = Promise.await (fst ps.(i)) in + let finish i = Promise.resolve (snd (ps.(i))) () in + Fiber.both + (fun () -> + Fiber.List.iter ~max_fibers:2 (process await) (List.init 4 Fun.id) + ) + (fun () -> + finish 1; + Fiber.yield (); + finish 2; + Fiber.yield (); Fiber.yield (); + finish 0; + Fiber.yield (); Fiber.yield (); + finish 3; + );; ++Start 0 ++Start 1 ++Finished 1 ++Start 2 ++Finished 2 ++Start 3 ++Finished 0 ++Finished 3 +- : unit = () +``` + +# Daemon fibers + +A daemon fiber runs until the non-daemon threads finish: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork_daemon ~sw (fun () -> + for i = 1 to 10 do + traceln "Daemon running"; + Fiber.yield () + done; + failwith "Test failed" + ); + traceln "Main running 1"; + Fiber.yield (); + traceln "Main running 2";; ++Daemon running ++Main running 1 ++Daemon running ++Main running 2 +- : unit = () +``` + +A more complex example with multiple daemon and non-daemon fibers: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork ~sw (fun () -> + traceln "Worker 1 starting"; + Fiber.yield (); + traceln "Worker 1 running"; + Fiber.yield (); + traceln "Worker 1 finished" + ); + Fiber.fork ~sw (fun () -> + traceln "Worker 2 starting"; + Fiber.yield (); + traceln "Worker 2 finished" + ); + Fiber.fork_daemon ~sw (fun () -> + try + for i = 1 to 10 do + traceln "Daemon 1 running"; + Fiber.yield () + done; + failwith "Test failed" + with Eio.Cancel.Cancelled _ as ex -> + traceln "Daemon cancelled; trying to spawn more fibers"; + Fiber.fork_daemon ~sw (fun () -> failwith "Shouldn't start"); + Fiber.fork ~sw (fun () -> failwith "Shouldn't start"); + raise ex + ); + Fiber.fork_daemon ~sw (fun () -> + traceln "Daemon 2 running"; + Fiber.yield (); + traceln "Daemon 2 finished"; + `Stop_daemon + ); + traceln "Main running"; + Fiber.yield (); + traceln "Main finished";; ++Worker 1 starting ++Worker 2 starting ++Daemon 1 running ++Daemon 2 running ++Main running ++Worker 1 running ++Worker 2 finished ++Daemon 1 running ++Daemon 2 finished ++Main finished ++Worker 1 finished ++Daemon cancelled; trying to spawn more fibers +- : unit = () +``` + +Failing daemon fibers still get their errors reported: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork_daemon ~sw (fun () -> + Fiber.yield (); + failwith "Simulated error" + ); + Fiber.yield ();; +Exception: Failure("Simulated error"). +- : unit = () +``` + +# Fiber-local storage + +Creating a context key: + +```ocaml +# let key : int Fiber.key = Fiber.create_key ();; +val key : int Fiber.key = + +# let trace_key () = + let value = Fiber.get key in + traceln "Key => %a" Fmt.(option ~none:(const string "") int) value;; +val trace_key : unit -> unit = +``` + +Keys default to being unset + +```ocaml +# Eio_js_backend.start @@ fun () -> + trace_key ();; ++Key => +- : unit = () +``` + +`with_binding` can be used to define a key. + +```ocaml +# Eio_js_backend.start @@ fun () -> + Fiber.with_binding key 123 @@ fun () -> trace_key ();; ++Key => 123 +- : unit = () +``` + +`with_binding` will shadow variables defined in outer scopes. + +```ocaml +# Eio_js_backend.start @@ fun () -> + Fiber.with_binding key 123 @@ fun () -> + trace_key (); + Fiber.with_binding key 456 (fun () -> trace_key ()); + trace_key ();; ++Key => 123 ++Key => 456 ++Key => 123 +- : unit = () +``` + +Values are propagated when forking: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Fiber.with_binding key 123 @@ fun () -> + Switch.run @@ fun sw -> + Fiber.fork ~sw trace_key;; ++Key => 123 +- : unit = () +``` + +Bindings can also be removed: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Fiber.with_binding key 123 @@ fun () -> + trace_key (); + Fiber.without_binding key (fun () -> trace_key ()); + trace_key ();; ++Key => 123 ++Key => ++Key => 123 +- : unit = () +``` + +Values are inherited from the currently running fiber, rather than the switch. + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + Fiber.with_binding key 123 @@ fun () -> + Fiber.fork ~sw trace_key;; ++Key => 123 +- : unit = () +``` + +## fork_seq + +The simple case where everything works: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + let seq = + Fiber.fork_seq ~sw (fun yield -> + traceln "Generator fiber starting"; + for i = 1 to 3 do + traceln "Yielding %d" i; + yield i + done + ) + in + traceln "Requesting 1st item"; + match seq () with + | Nil -> assert false + | Cons (x, seq) -> + traceln "hd = %d" x; + traceln "Requesting remaining items"; + List.of_seq seq |> traceln "%a" Fmt.(Dump.list int);; ++Requesting 1st item ++Generator fiber starting ++Yielding 1 ++hd = 1 ++Requesting remaining items ++Yielding 2 ++Yielding 3 ++[2; 3] +- : unit = () +``` + +The generator raises: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + let seq = + Fiber.fork_seq ~sw (fun yield -> + traceln "Generator fiber starting"; + raise (Failure "Simulated error") + ) + in + Eio.Cancel.protect (fun () -> (* (ensure we get the exception from the sequence) *) + traceln "Requesting an item"; + try + ignore (seq ()); + assert false + with ex -> traceln "Consumer got exception: %a" Fmt.exn ex + );; ++Requesting an item ++Generator fiber starting ++Consumer got exception: Failure("Simulated error") +- : unit = () +``` + +The sequence is used after the switch is finished: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let seq = + Switch.run (fun sw -> + Fiber.fork_seq ~sw (fun _yield -> assert false) + ) + in + traceln "Requesting an item"; + ignore (seq ());; ++Requesting an item +Exception: +Invalid_argument("Coroutine has already failed: Cancelled: Stdlib.Exit"). +- : unit = () +``` + +The sequence is used after the switch is finished, and the generator has started: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let seq = + Switch.run (fun sw -> + let seq = + Fiber.fork_seq ~sw (fun yield -> + try yield 1 + with ex -> traceln "Generator caught: %a" Fmt.exn ex; raise ex + ) + in + traceln "Requesting an item"; + match seq () with + | Nil -> assert false + | Cons (x, seq) -> + traceln "Got %d" x; + seq + ) + in + traceln "Switch finished. Requesting another item..."; + ignore (seq ());; ++Requesting an item ++Got 1 ++Generator caught: Cancelled: Stdlib.Exit ++Switch finished. Requesting another item... +Exception: +Invalid_argument("Coroutine has already failed: Cancelled: Stdlib.Exit"). +- : unit = () +``` + +Using a sequence after it has finished normally: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + let seq = Fiber.fork_seq ~sw (fun yield -> yield 1; traceln "Generator done") in + let next = Seq.to_dispenser seq in + traceln "Got %a" Fmt.(Dump.option int) (next ()); + traceln "Got %a" Fmt.(Dump.option int) (next ()); + ignore (next ());; ++Got Some 1 ++Generator done ++Got None +Exception: Invalid_argument("Coroutine has already finished!"). +- : unit = () +``` + +Trying to resume twice: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + let seq = Fiber.fork_seq ~sw (fun _yield -> Fiber.await_cancel ()) in + Fiber.both + (fun () -> ignore (seq ())) + (fun () -> ignore (seq ()));; +Exception: Invalid_argument("Coroutine is still running!"). +- : unit = () +``` + +Generator yields twice for a single request: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + let seq = Fiber.fork_seq ~sw (fun yield -> Fiber.both yield yield) in + ignore (seq ());; +Exception: Invalid_argument("Coroutine has already yielded!"). +- : unit = () +``` + +Yielding from a different fiber (note: end-of-sequence is still sent when the original fiber exits): + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + let seq = Fiber.fork_seq ~sw (fun yield -> + let p = Fiber.fork_promise ~sw (fun () -> Fiber.yield (); yield "Second fiber") in + Promise.await_exn p; + yield "Original fiber" + ) in + List.of_seq seq |> traceln "%a" Fmt.Dump.(list string);; ++["Second fiber"; "Original fiber"] +- : unit = () +``` + +The consumer cancels: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + let seq = Fiber.fork_seq ~sw (fun yield -> + traceln "Working..."; + try + Fiber.yield (); + yield 1 + with ex -> traceln "Generator caught: %a" Fmt.exn ex; raise ex + ) in + let s = + Fiber.first + (fun () -> seq ()) + (fun () -> Nil) + in + assert (s = Seq.Nil);; ++Working... ++Generator caught: Cancelled: Eio__core__Fiber.Not_first +- : unit = () +``` + +The generator is cancelled while queued to be resumed. +It runs, but cancels at the next opportunity: + +```ocaml +# Eio_js_backend.start @@ fun () -> + Switch.run @@ fun sw -> + let seq = Fiber.fork_seq ~sw (fun yield -> + traceln "Working..."; + try Fiber.check () + with ex -> traceln "Generator caught: %a" Fmt.exn ex; raise ex + ) in + traceln "Enqueue resume"; + Fiber.both + (fun () -> ignore (seq () : _ Seq.node); assert false) + (fun () -> + traceln "Cancel generator"; + Switch.fail sw Exit + ) ++Enqueue resume ++Cancel generator ++Working... ++Generator caught: Cancelled: Stdlib.Exit +Exception: Stdlib.Exit. +- : unit = () +``` diff --git a/lib_eio_js_backend/tests/lazy.md b/lib_eio_js_backend/tests/lazy.md new file mode 100644 index 000000000..0f26edb22 --- /dev/null +++ b/lib_eio_js_backend/tests/lazy.md @@ -0,0 +1,131 @@ +# Setting up the environment + +```ocaml +# #require "eio_js_backend";; +``` +```ocaml +open Eio.Std + +let test label v = + traceln "%s: forcing..." label; + match Eio.Lazy.force v with + | v -> + Fiber.check (); + traceln "%s: %d" label v + | exception ex -> + traceln "%s: %a" label Fmt.exn ex; + Fiber.check () +``` + +# Tests + +Two fibers request the value. It's only computed once: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let v = Eio.Lazy.from_fun ~cancel:`Restart (fun () -> + traceln "calculating..."; + Fiber.yield (); + traceln "complete"; + 42 + ) in + Fiber.both + (fun () -> test "a" v) + (fun () -> test "b" v) + ;; ++a: forcing... ++calculating... ++b: forcing... ++complete ++a: 42 ++b: 42 +- : unit = () +``` + +The calculation fails. It's still only performed once: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let v = Eio.Lazy.from_fun ~cancel:`Restart (fun () -> + traceln "calculating..."; + Fiber.yield (); + failwith "failed"; + ) in + Fiber.both + (fun () -> test "a" v) + (fun () -> test "b" v) + ;; ++a: forcing... ++calculating... ++b: forcing... ++a: Failure("failed") ++b: Failure("failed") +- : unit = () +``` + +## Cancellation + +The first fiber cancels. What happens depends on the cancel mode: + +```ocaml +let test_cancel cancel = + Eio_js_backend.start @@ fun () -> + let v = Eio.Lazy.from_fun ~cancel (fun () -> + traceln "calculating..."; + Fiber.yield (); + traceln "complete"; + 42 + ) in + Fiber.both + (fun () -> + let x = + Fiber.first + (fun () -> test "a" v; assert false) + (fun () -> 5) + in + traceln "a: %d" x + ) + (fun () -> test "b" v) + ;; +``` + +In record mode, the second fiber sees the cancelled exception: + +```ocaml +# test_cancel `Record;; ++a: forcing... ++calculating... ++b: forcing... ++a: Cancelled: Eio__core__Fiber.Not_first ++b: Cancelled: Eio__core__Fiber.Not_first ++a: 5 +- : unit = () +``` + +In protect mode, the first calculation succeeds: + +```ocaml +# test_cancel `Protect;; ++a: forcing... ++calculating... ++b: forcing... ++complete ++b: 42 ++a: 5 +- : unit = () +``` + +In restart mode, the second fiber restarts the calculation: + +```ocaml +# test_cancel `Restart;; ++a: forcing... ++calculating... ++b: forcing... ++a: Cancelled: Eio__core__Fiber.Not_first ++calculating... ++a: 5 ++complete ++b: 42 +- : unit = () +``` diff --git a/lib_eio_js_backend/tests/mutex.md b/lib_eio_js_backend/tests/mutex.md new file mode 100644 index 000000000..4f22629c2 --- /dev/null +++ b/lib_eio_js_backend/tests/mutex.md @@ -0,0 +1,259 @@ +# Setting up the environment + +```ocaml +# #require "eio_js_backend";; +# Eio_js_backend.set_uncaught_exception_handler + (fun exn _ -> Format.eprintf "@[Exception:@ %s.@]@." (Printexc.to_string exn)) +- : unit = () +``` + +```ocaml +open Eio.Std + +module M = Eio.Mutex + +let run = Eio_js_backend.start + +let lock t = + traceln "Locking"; + M.lock t; + traceln "Locked" + +let unlock t = + traceln "Unlocking"; + M.unlock t; + traceln "Unlocked" +``` + +# Test cases + +Simple case + +```ocaml +# run @@ fun () -> + let t = M.create () in + lock t; + unlock t; + lock t; + unlock t;; ++Locking ++Locked ++Unlocking ++Unlocked ++Locking ++Locked ++Unlocking ++Unlocked +- : unit = () +``` + +Concurrent access to the mutex + + +```ocaml +# run @@ fun () -> + let t = M.create () in + let fn () = + lock t; + Eio.Fiber.yield (); + unlock t + in + List.init 4 (fun _ -> fn) + |> Fiber.all;; ++Locking ++Locked ++Locking ++Locking ++Locking ++Unlocking ++Unlocked ++Locked ++Unlocking ++Unlocked ++Locked ++Unlocking ++Unlocked ++Locked ++Unlocking ++Unlocked +- : unit = () +``` + +Double unlock raises an exception + +```ocaml +# run @@ fun () -> + let t = M.create () in + M.lock t; + M.unlock t; + begin + try M.unlock t + with Sys_error msg -> traceln "Caught: %s" msg + end; + traceln "Trying to use lock after error..."; + M.lock t;; ++Caught: Eio.Mutex.unlock: already unlocked! ++Trying to use lock after error... +Exception: Eio__Eio_mutex.Poisoned(_). +- : unit = () +``` + +## Read-write access + +Successful use; only one critical section is active at once: + +```ocaml +# run @@ fun () -> + let t = M.create () in + let fn () = + traceln "Entered critical section"; + Fiber.yield (); + traceln "Leaving critical section" + in + Fiber.both + (fun () -> M.use_rw ~protect:true t fn) + (fun () -> M.use_rw ~protect:true t fn);; ++Entered critical section ++Leaving critical section ++Entered critical section ++Leaving critical section +- : unit = () +``` + +A failed critical section will poison the mutex: + +```ocaml +# run @@ fun () -> + let t = M.create () in + try + M.use_rw ~protect:true t (fun () -> failwith "Simulated error"); + with Failure _ -> + traceln "Trying to use the failed lock again fails:"; + M.lock t;; ++Trying to use the failed lock again fails: +Exception: Eio__Eio_mutex.Poisoned(_). +- : unit = () +``` + +## Protection + +We can prevent cancellation during a critical section: + +```ocaml +# run @@ fun () -> + let t = M.create () in + Fiber.both + (fun () -> + M.use_rw ~protect:true t (fun () -> Fiber.yield (); traceln "Restored invariant"); + Fiber.check (); + traceln "Error: not cancelled!"; + ) + (fun () -> traceln "Cancelling..."; failwith "Simulated error");; ++Cancelling... ++Restored invariant +Exception: Failure("Simulated error"). +- : unit = () +``` + +Or allow interruption and disable the mutex: + +```ocaml +# run @@ fun () -> + let t = M.create () in + try + Fiber.both + (fun () -> + M.use_rw ~protect:false t (fun () -> Fiber.yield (); traceln "Restored invariant") + ) + (fun () -> traceln "Cancelling..."; failwith "Simulated error"); + with ex -> + traceln "Trying to reuse the failed mutex..."; + M.use_ro t (fun () -> assert false);; ++Cancelling... ++Trying to reuse the failed mutex... +Exception: Eio__Eio_mutex.Poisoned(_). +- : unit = () +``` + +Protection doesn't prevent cancellation while we're still waiting for the lock, though: + +```ocaml +# run @@ fun () -> + let t = M.create () in + M.lock t; + try + Fiber.both + (fun () -> M.use_rw ~protect:true t (fun () -> assert false)) + (fun () -> traceln "Cancelling..."; failwith "Simulated error") + with Failure _ -> + M.unlock t; + M.use_ro t (fun () -> traceln "Can reuse the mutex");; ++Cancelling... ++Can reuse the mutex +- : unit = () +``` + +Poisoning wakes any wakers: + +```ocaml +# run @@ fun () -> + let t = M.create () in + Fiber.both + (fun () -> + try + M.use_rw ~protect:false t (fun () -> + Fiber.yield (); + traceln "Poisoning mutex"; + failwith "Simulated error" + ) + with Failure _ -> () + ) + (fun () -> traceln "Waiting for lock..."; M.use_ro t (fun () -> assert false));; ++Waiting for lock... ++Poisoning mutex +Exception: Eio__Eio_mutex.Poisoned(_). +- : unit = () +``` + + +## Read-only access + +If the resource isn't being mutated, we can just unlock on error: + +```ocaml +# run @@ fun () -> + let t = M.create () in + try + M.use_ro t (fun () -> failwith "Simulated error"); + with Failure msg -> + traceln "Caught: %s" msg; + traceln "Trying to use the lock again is OK:"; + M.lock t;; ++Caught: Simulated error ++Trying to use the lock again is OK: +- : unit = () +``` + +## Try_lock + +```ocaml +# run @@ fun () -> + let t = M.create () in + let fn () = + match M.try_lock t with + | true -> + traceln "Entered critical section"; + Fiber.yield (); + traceln "Leaving critical section"; + M.unlock t + | false -> + traceln "Failed to get lock" + in + Fiber.both fn fn; + M.use_ro t (fun () -> traceln "Lock still works");; ++Entered critical section ++Failed to get lock ++Leaving critical section ++Lock still works +- : unit = () +``` diff --git a/lib_eio_js_backend/tests/pool.md b/lib_eio_js_backend/tests/pool.md new file mode 100644 index 000000000..e3ecb2d03 --- /dev/null +++ b/lib_eio_js_backend/tests/pool.md @@ -0,0 +1,208 @@ +# Setting up the environment + +```ocaml +# #require "eio_js_backend";; +# Eio_js_backend.set_uncaught_exception_handler + (fun exn _ -> Format.eprintf "@[Exception:@ %s.@]@." (Printexc.to_string exn)) +- : unit = () +``` + +```ocaml +open Eio.Std + +module P = Eio.Pool + +let dispose x = traceln "disposing %d" x + +let create ?validate ?dispose n items = + let items = Array.of_list items in + let i = ref 0 in + P.create ?validate ?dispose n (fun () -> + traceln "Creating item %d" !i; + let p = items.(!i) in + incr i; + Promise.await_exn p + ) +``` + +# Test cases + +Simple case: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let t = create 1 [Promise.create_resolved (Ok 0)] in + P.use t (fun x -> traceln "Using item %d" x); + P.use t (fun x -> traceln "Using item %d" x); ++Creating item 0 ++Using item 0 ++Using item 0 +- : unit = () +``` + +Two uses with a capacity of 1; the second must wait: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let p, r = Promise.create () in + let t = create 1 [p] in + Fiber.all [ + (fun () -> P.use t (fun x -> traceln "A: using item %d" x; Fiber.yield (); traceln "A done")); + (fun () -> P.use t (fun x -> traceln "B: using item %d" x; Fiber.yield (); traceln "B done")); + (fun () -> Promise.resolve r (Ok 0)); + ]; ++Creating item 0 ++A: using item 0 ++A done ++B: using item 0 ++B done +- : unit = () +``` + +Two uses with a capacity of 2; they run in parallel: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let p0, r0 = Promise.create () in + let p1, r1 = Promise.create () in + let t = create 2 [p0; p1] in + Fiber.all [ + (fun () -> P.use t (fun x -> traceln "A: using item %d" x; Fiber.yield (); traceln "A done")); + (fun () -> P.use t (fun x -> traceln "B: using item %d" x; Fiber.yield (); traceln "B done")); + (fun () -> Promise.resolve r0 (Ok 0); Promise.resolve r1 (Ok 1)); + ]; ++Creating item 0 ++A: using item 0 ++Creating item 1 ++B: using item 1 ++A done ++B done +- : unit = () +``` + +## Cancellation + +```ocaml +# Eio_js_backend.start @@ fun () -> + let p, r = Promise.create () in + let t = create 1 [p] in + Fiber.all [ + (fun () -> P.use t (fun _ -> assert false)); (* Waits for the creation to finish *) + (fun () -> P.use t (fun _ -> assert false)); (* Waits for the item to be returned *) + (fun () -> failwith "Simulated error"); + ]; ++Creating item 0 +Exception: Failure("Simulated error"). +- : unit = () +``` + +## Error handling + +On error, the resource is still returned to the pool: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let t = create 1 [Promise.create_resolved (Ok 0)] in + begin + try P.use t (fun x -> traceln "Using item %d" x; failwith "Simulated error") + with Failure msg -> traceln "Failed: %s" msg + end; + P.use t (fun x -> traceln "Using item %d" x); ++Creating item 0 ++Using item 0 ++Failed: Simulated error ++Using item 0 +- : unit = () +``` + +Two fibers are trying to use a resource and one is being created. +When the creation function fails, the first fiber reports the error, +and also wakes the second fiber, which tries again: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let p, r = Promise.create () in + let t = create 1 [p; Promise.create_resolved (Ok 1)] in + Switch.run @@ fun sw -> + let a = Fiber.fork_promise ~sw (fun () -> P.use t (fun i -> traceln "A: using item %d" i)) in + Fiber.both + (fun () -> P.use t (fun i -> traceln "B: using item %d" i)) + (fun () -> Promise.resolve_error r (Failure "Simulated creation failure")); + Promise.await_exn a ++Creating item 0 ++Creating item 1 ++B: using item 1 +Exception: Failure("Simulated creation failure"). +- : unit = () +``` + +## Validation + +The second time a resource is used, we check it is still valid: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let validate x = + let ok = (x land 1) = 0 in + traceln "validate %d => %b" x ok; + ok + in + let t = create ~validate ~dispose 2 [ + Promise.create_resolved (Ok 0); + Promise.create_resolved (Ok 1); + Promise.create_resolved (Ok 2); + ] in + Fiber.all [ + (fun () -> P.use t (fun x -> traceln "A: using item %d" x; Fiber.yield ())); + (fun () -> P.use t (fun x -> traceln "B: using item %d" x; Fiber.yield ())); + (fun () -> P.use t (fun x -> traceln "C: using item %d" x; Fiber.yield ())); + (fun () -> P.use t (fun x -> traceln "D: using item %d" x; Fiber.yield ())); + ] ++Creating item 0 ++A: using item 0 ++Creating item 1 ++B: using item 1 ++validate 0 => true ++C: using item 0 ++validate 1 => false ++disposing 1 ++Creating item 2 ++D: using item 2 +- : unit = () +``` + +Dispose fails. We report the error, but still recreate the resource next time: + +```ocaml +# Eio_js_backend.start @@ fun () -> + let validate x = + let ok = (x land 1) = 1 in + traceln "validate %d => %b" x ok; + ok + in + let dispose x = Fmt.failwith "Simulated error disposing %d" x in + let t = create ~validate ~dispose 1 [ + Promise.create_resolved (Ok 0); + Promise.create_resolved (Ok 1); + Promise.create_resolved (Ok 2); + ] in + begin + try + Fiber.both + (fun () -> P.use t (fun x -> traceln "A: using item %d" x; Fiber.yield ())) + (fun () -> P.use t (fun x -> traceln "B: using item %d" x; Fiber.yield ())) + with Failure msg -> traceln "Failed: %s" msg + end; + Fiber.both + (fun () -> P.use t (fun x -> traceln "C: using item %d" x; Fiber.yield ())) + (fun () -> P.use t (fun x -> traceln "D: using item %d" x; Fiber.yield ())) ++Creating item 0 ++A: using item 0 ++validate 0 => false ++Failed: Simulated error disposing 0 ++Creating item 1 ++C: using item 1 ++validate 1 => true ++D: using item 1 +- : unit = () +``` diff --git a/lib_eio_js_backend/tests/semaphore.md b/lib_eio_js_backend/tests/semaphore.md new file mode 100644 index 000000000..aec5e55fa --- /dev/null +++ b/lib_eio_js_backend/tests/semaphore.md @@ -0,0 +1,96 @@ +# Setting up the environment + +```ocaml +# #require "eio_js_backend";; +``` + +```ocaml +open Eio.Std + +module T = Eio.Semaphore + +let run fn = + Eio_js_backend.start @@ fun _ -> + fn () + +let acquire t = + traceln "Acquiring"; + T.acquire t; + traceln "Acquired" + +let release t = + traceln "Releasing"; + T.release t; + traceln "Released" +``` + +# Test cases + +Simple case: + +```ocaml +# run @@ fun () -> + let t = T.make 1 in + acquire t; + release t; + acquire t; + release t;; ++Acquiring ++Acquired ++Releasing ++Released ++Acquiring ++Acquired ++Releasing ++Released +- : unit = () +``` + +Concurrent access to the semaphore: + +```ocaml +# run @@ fun () -> + let t = T.make 2 in + let fn () = + acquire t; + Eio.Fiber.yield (); + release t + in + List.init 4 (fun _ -> fn) + |> Fiber.all;; ++Acquiring ++Acquired ++Acquiring ++Acquired ++Acquiring ++Acquiring ++Releasing ++Released ++Releasing ++Released ++Acquired ++Acquired ++Releasing ++Released ++Releasing ++Released +- : unit = () +``` + +Cancellation: + +```ocaml +# run @@ fun () -> + let t = T.make 0 in + Fiber.first + (fun () -> acquire t) + (fun () -> ()); + release t; + acquire t;; ++Acquiring ++Releasing ++Released ++Acquiring ++Acquired +- : unit = () +``` diff --git a/lib_eio_js_backend/tests/stream.md b/lib_eio_js_backend/tests/stream.md new file mode 100644 index 000000000..804c90715 --- /dev/null +++ b/lib_eio_js_backend/tests/stream.md @@ -0,0 +1,357 @@ +# Setting up the environment + +```ocaml +# #require "eio_js_backend";; +``` + +```ocaml +open Eio.Std + +module S = Eio.Stream + +exception Cancel + +let run = Eio_js_backend.start + +let add t v = + traceln "Adding %d to stream" v; + S.add t v; + traceln "Added %d to stream" v + +let take t = + traceln "Reading from stream"; + traceln "Got %d from stream" (S.take t) + +let take_nonblocking t = + traceln "Reading from stream"; + traceln "Got %a from stream" Fmt.(option ~none:(any "None") int) (S.take_nonblocking t) +``` + +# Test cases + +Simple non-blocking case + +```ocaml +# run @@ fun () -> + let t = S.create 2 in + add t 1; + add t 2; + take t; + take t;; ++Adding 1 to stream ++Added 1 to stream ++Adding 2 to stream ++Added 2 to stream ++Reading from stream ++Got 1 from stream ++Reading from stream ++Got 2 from stream +- : unit = () +``` + +Readers have to wait when the stream is empty: + +```ocaml +# run @@ fun () -> + let t = S.create 2 in + add t 1; + Fiber.both + (fun () -> take t; take t) + (fun () -> add t 2);; ++Adding 1 to stream ++Added 1 to stream ++Reading from stream ++Got 1 from stream ++Reading from stream ++Adding 2 to stream ++Added 2 to stream ++Got 2 from stream +- : unit = () +``` + +Writers have to wait when the stream is full: + +```ocaml +# run @@ fun () -> + let t = S.create 3 in + add t 1; + Fiber.both + (fun () -> + add t 2; + add t 3; + add t 4; + ) + (fun () -> + take t; + take t; + take t; + take t + );; ++Adding 1 to stream ++Added 1 to stream ++Adding 2 to stream ++Added 2 to stream ++Adding 3 to stream ++Added 3 to stream ++Adding 4 to stream ++Reading from stream ++Got 1 from stream ++Reading from stream ++Got 2 from stream ++Reading from stream ++Got 3 from stream ++Reading from stream ++Got 4 from stream ++Added 4 to stream +- : unit = () +``` + +A zero-length queue is synchronous: + +```ocaml +# run @@ fun () -> + let t = S.create 0 in + Fiber.both + (fun () -> + add t 1; + add t 2; + ) + (fun () -> + take t; + take t; + );; ++Adding 1 to stream ++Reading from stream ++Got 1 from stream ++Reading from stream ++Added 1 to stream ++Adding 2 to stream ++Added 2 to stream ++Got 2 from stream +- : unit = () +``` + +Cancel reading from a stream: + +```ocaml +# run @@ fun () -> + let t = S.create 1 in + try + Fiber.both + (fun () -> take t) + (fun () -> raise Cancel); + assert false; + with Cancel -> + traceln "Cancelled"; + add t 2; + take t;; ++Reading from stream ++Cancelled ++Adding 2 to stream ++Added 2 to stream ++Reading from stream ++Got 2 from stream +- : unit = () +``` + +Cancel writing to a stream: + +```ocaml +# run @@ fun () -> + let t = S.create 1 in + try + Fiber.both + (fun () -> add t 1; add t 2) + (fun () -> raise Cancel); + assert false; + with Cancel -> + traceln "Cancelled"; + take t; + add t 3; + take t;; ++Adding 1 to stream ++Added 1 to stream ++Adding 2 to stream ++Cancelled ++Reading from stream ++Got 1 from stream ++Adding 3 to stream ++Added 3 to stream ++Reading from stream ++Got 3 from stream +- : unit = () +``` + +Cancel writing to a zero-length stream: + +```ocaml +# run @@ fun () -> + let t = S.create 0 in + try + Fiber.both + (fun () -> add t 1) + (fun () -> raise Cancel); + assert false; + with Cancel -> + traceln "Cancelled"; + Fiber.both + (fun () -> add t 2) + (fun () -> take t);; ++Adding 1 to stream ++Cancelled ++Adding 2 to stream ++Reading from stream ++Got 2 from stream ++Added 2 to stream +- : unit = () +``` + +Trying to use a stream with a cancelled context: + +```ocaml +# run @@ fun () -> + let t = S.create 0 in + Eio.Cancel.sub @@ fun c -> + Eio.Cancel.cancel c Cancel; + begin try add t 1 with ex -> traceln "%a" Fmt.exn ex end; + begin try take t with ex -> traceln "%a" Fmt.exn ex end; + (* Check we released the mutex correctly: *) + Eio.Cancel.protect @@ fun () -> + Fiber.both + (fun () -> add t 1) + (fun () -> take t) + ;; ++Adding 1 to stream ++Cancelled: Cancel ++Reading from stream ++Cancelled: Cancel ++Adding 1 to stream ++Reading from stream ++Got 1 from stream ++Added 1 to stream +- : unit = () +``` + +Readers queue up: + +```ocaml +# run @@ fun () -> + let t = S.create 0 in + Switch.run @@ fun sw -> + Fiber.fork ~sw (fun () -> take t; traceln "a done"); + Fiber.fork ~sw (fun () -> take t; traceln "b done"); + Fiber.fork ~sw (fun () -> take t; traceln "c done"); + add t 1; + add t 2; + add t 3;; ++Reading from stream ++Reading from stream ++Reading from stream ++Adding 1 to stream ++Added 1 to stream ++Adding 2 to stream ++Added 2 to stream ++Adding 3 to stream ++Added 3 to stream ++Got 1 from stream ++a done ++Got 2 from stream ++b done ++Got 3 from stream ++c done +- : unit = () +``` + +Writers queue up: + +```ocaml +# run @@ fun () -> + let t = S.create 0 in + Switch.run @@ fun sw -> + Fiber.fork ~sw (fun () -> add t 1); + Fiber.fork ~sw (fun () -> add t 2); + Fiber.fork ~sw (fun () -> add t 3); + take t; + take t; + take t;; ++Adding 1 to stream ++Adding 2 to stream ++Adding 3 to stream ++Reading from stream ++Got 1 from stream ++Reading from stream ++Got 2 from stream ++Reading from stream ++Got 3 from stream ++Added 1 to stream ++Added 2 to stream ++Added 3 to stream +- : unit = () +``` + +Cancelling writing to a stream: + +```ocaml +# run @@ fun () -> + let t = S.create 1 in + add t 0; + Switch.run @@ fun sw -> + try + Fiber.both + (fun () -> add t 1) + (fun () -> raise Cancel) + with Cancel -> + traceln "Cancelled"; + take t; + add t 2; + take t;; ++Adding 0 to stream ++Added 0 to stream ++Adding 1 to stream ++Cancelled ++Reading from stream ++Got 0 from stream ++Adding 2 to stream ++Added 2 to stream ++Reading from stream ++Got 2 from stream +- : unit = () +``` + +Non-blocking take: + +```ocaml +# run @@ fun () -> + let t = S.create 1 in + take_nonblocking t; + add t 0; + take_nonblocking t;; ++Reading from stream ++Got None from stream ++Adding 0 to stream ++Added 0 to stream ++Reading from stream ++Got 0 from stream +- : unit = () +``` + +Non-blocking take with zero-capacity stream: + +```ocaml +# run @@ fun () -> + let t = S.create 0 in + take_nonblocking t; + Fiber.both + (fun () -> add t 0) + (fun () -> take_nonblocking t); + take_nonblocking t;; ++Reading from stream ++Got None from stream ++Adding 0 to stream ++Reading from stream ++Got 0 from stream ++Added 0 to stream ++Reading from stream ++Got None from stream +- : unit = () +``` diff --git a/lib_eio_js_backend/tests/switch.md b/lib_eio_js_backend/tests/switch.md new file mode 100644 index 000000000..b156cb9cb --- /dev/null +++ b/lib_eio_js_backend/tests/switch.md @@ -0,0 +1,429 @@ +# Setting up the environment + +```ocaml +# #require "eio_js_backend";; +# Eio_js_backend.set_uncaught_exception_handler + (fun exn _ -> Format.eprintf "@[Exception:@ %s.@]@." (Printexc.to_string exn)) +- : unit = () +``` + +```ocaml +open Eio.Std + +let run (fn : Switch.t -> _) = + Eio_js_backend.start @@ fun () -> + Switch.run fn + +let fork_sub ~sw ~on_error fn = + Fiber.fork ~sw (fun () -> + try Switch.run fn + with + | Eio.Cancel.Cancelled _ -> () + | ex -> on_error ex + ) +``` + +# Test cases + +A very basic example: + +```ocaml +# run (fun _sw -> + traceln "Running" + );; ++Running +- : unit = () +``` + +Turning off a switch still allows you to perform clean-up operations: + +```ocaml +# run (fun sw -> + traceln "Running"; + Switch.fail sw (Failure "Cancel"); + traceln "Clean up" + );; ++Running ++Clean up +Exception: Failure("Cancel"). +- : unit = () +``` + +`Fiber.both`, both fibers pass: + +```ocaml +# run (fun _sw -> + Fiber.both + (fun () -> for i = 1 to 2 do traceln "i = %d" i; Fiber.yield () done) + (fun () -> for j = 1 to 2 do traceln "j = %d" j; Fiber.yield () done) + );; ++i = 1 ++j = 1 ++i = 2 ++j = 2 +- : unit = () +``` + +`Fiber.both`, only 1st succeeds: + +```ocaml +# run (fun sw -> + Fiber.both + (fun () -> for i = 1 to 5 do traceln "i = %d" i; Fiber.yield () done) + (fun () -> failwith "Failed") + );; ++i = 1 +Exception: Failure("Failed"). +- : unit = () +``` + +`Fiber.both`, only 2nd succeeds: + +```ocaml +# run (fun sw -> + Fiber.both + (fun () -> Fiber.yield (); failwith "Failed") + (fun () -> for i = 1 to 5 do traceln "i = %d" i; Fiber.yield () done) + );; ++i = 1 +Exception: Failure("Failed"). +- : unit = () +``` + +`Fiber.both`, first fails immediately and the other doesn't start: + +```ocaml +# run (fun sw -> + Fiber.both (fun () -> failwith "Failed") (fun () -> traceln "Second OK"); + traceln "Not reached" + );; +Exception: Failure("Failed"). +- : unit = () +``` + +`Fiber.both`, second fails but the other doesn't stop: + +```ocaml +# run (fun sw -> + Fiber.both ignore (fun () -> failwith "Failed"); + traceln "not reached" + );; +Exception: Failure("Failed"). +- : unit = () +``` + +`Fiber.both`, both fibers fail: + +```ocaml +# run (fun sw -> + Fiber.both + (fun () -> Eio.Cancel.protect Fiber.yield; failwith "Failed 1") + (fun () -> Eio.Cancel.protect Fiber.yield; failwith "Failed 2") + );; +Exception: Multiple exceptions: +- Failure("Failed 1") +- Failure("Failed 2"). +- : unit = () +``` + +The switch is already turned off when we try to fork. The new fiber doesn't start: + +```ocaml +# run (fun sw -> + Switch.fail sw (Failure "Cancel"); + Fiber.fork ~sw (fun () -> traceln "Not reached"); + traceln "Main continues" + );; ++Main continues +Exception: Failure("Cancel"). +- : unit = () +``` + +Wait for either a promise or a cancellation; cancellation first: +```ocaml +# run (fun sw -> + let p, r = Promise.create () in + Fiber.fork ~sw (fun () -> + Fiber.both + (fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved") + (fun () -> failwith "Cancelled") + ); + Fiber.yield (); + Promise.resolve r (); + traceln "Main thread done"; + );; ++Waiting ++Main thread done +Exception: Failure("Cancelled"). +- : unit = () +``` + +Wait for either a promise or a switch; promise resolves first: + +```ocaml +# run (fun sw -> + let p, r = Promise.create () in + Fiber.fork ~sw (fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved"); + Promise.resolve r (); + Fiber.yield (); + traceln "Now cancelling..."; + Switch.fail sw (Failure "Cancelled") + );; ++Waiting ++Resolved ++Now cancelling... +Exception: Failure("Cancelled"). +- : unit = () +``` + +Wait for either a promise or a switch; switch cancelled first. Result version. + +```ocaml +# run (fun sw -> + let p, r = Promise.create () in + Fiber.fork ~sw (fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved"); + Switch.fail sw (Failure "Cancelled"); + Promise.resolve r () + );; ++Waiting +Exception: Failure("Cancelled"). +- : unit = () +``` + +Wait for either a promise or a switch; promise resolves first but switch off without yielding: + +```ocaml +# run (fun sw -> + let p, r = Promise.create () in + Fiber.fork ~sw (fun () -> traceln "Waiting"; Promise.await p; traceln "Resolved"); + Promise.resolve r (); + traceln "Now cancelling..."; + Switch.fail sw (Failure "Cancelled") + );; ++Waiting ++Now cancelling... ++Resolved +Exception: Failure("Cancelled"). +- : unit = () +``` + +Child switches are cancelled when the parent is cancelled, but `on_error` isn't notified: + +```ocaml +# run (fun sw -> + let p, _ = Promise.create () in + let on_error ex = traceln "child: %s" (Printexc.to_string ex) in + fork_sub ~sw ~on_error (fun sw -> traceln "Child 1"; Promise.await p); + fork_sub ~sw ~on_error (fun sw -> traceln "Child 2"; Promise.await p); + Switch.fail sw (Failure "Cancel parent") + );; ++Child 1 ++Child 2 +Exception: Failure("Cancel parent"). +- : unit = () +``` + +A child can fail independently of the parent: + +```ocaml +# run (fun sw -> + let p1, r1 = Promise.create () in + let p2, r2 = Promise.create () in + let on_error ex = traceln "child: %s" (Printexc.to_string ex) in + fork_sub ~sw ~on_error (fun sw -> traceln "Child 1"; Promise.await_exn p1); + fork_sub ~sw ~on_error (fun sw -> traceln "Child 2"; Promise.await_exn p2); + Promise.resolve_error r1 (Failure "Child error"); + Promise.resolve_ok r2 (); + Fiber.yield (); + traceln "Parent fiber is still running" + );; ++Child 1 ++Child 2 ++child: Failure("Child error") ++Parent fiber is still running +- : unit = () +``` + +A child can be cancelled independently of the parent: + +```ocaml +# run (fun sw -> + let p, _ = Promise.create () in + let on_error ex = traceln "child: %s" (Printexc.to_string ex) in + let child = ref None in + fork_sub ~sw ~on_error (fun sw -> + traceln "Child 1"; + child := Some sw; + Promise.await ~sw p + ); + Switch.fail (Option.get !child) (Failure "Cancel child"); + Fiber.yield (); + traceln "Parent fiber is still running" + );; ++Child 1 ++child: Failure("Cancel child") ++Parent fiber is still running +- : unit = () +``` + +A child error handler raises: + +```ocaml +# run (fun sw -> + let p, r = Promise.create () in + let on_error = raise in + fork_sub ~sw ~on_error (fun sw -> traceln "Child"; Promise.await_exn p); + Promise.resolve_error r (Failure "Child error escapes"); + Fiber.yield (); + traceln "Not reached" + );; ++Child +Exception: Failure("Child error escapes"). +- : unit = () +``` + +A child error handler deals with the exception: + +```ocaml +# run (fun sw -> + let p, r = Promise.create () in + let on_error = traceln "caught: %a" Fmt.exn in + fork_sub ~sw ~on_error (fun sw -> traceln "Child"; Promise.await_exn p); + Promise.resolve_error r (Failure "Child error is caught"); + Fiber.yield (); + traceln "Still running" + );; ++Child ++caught: Failure("Child error is caught") ++Still running +- : unit = () +``` + +# Release handlers + +```ocaml +let release label = Fiber.yield (); traceln "release %s" label +``` + +Release on success: + +```ocaml +# run (fun sw -> + Switch.on_release sw (fun () -> release "1"); + Switch.on_release sw (fun () -> release "2"); + );; ++release 2 ++release 1 +- : unit = () +``` + +Release on error: + +```ocaml +# run (fun sw -> + Switch.on_release sw (fun () -> release "1"); + Switch.on_release sw (fun () -> release "2"); + failwith "Test error" + );; ++release 2 ++release 1 +Exception: Failure("Test error"). +- : unit = () +``` + +A release operation itself fails: + +```ocaml +# run (fun sw -> + Switch.on_release sw (fun () -> release "1"; failwith "failure 1"); + Switch.on_release sw (fun () -> release "2"); + Switch.on_release sw (fun () -> release "3"; failwith "failure 3"); + );; ++release 3 ++release 2 ++release 1 +Exception: +Multiple exceptions: +- Failure("failure 3") +- Failure("failure 1"). +- : unit = () +``` + +Attaching a release handler to a finished switch from a cancelled context: + +```ocaml +# run @@ fun sw -> + let sub = Switch.run Fun.id in (* A finished switch *) + Switch.fail sw (Failure "Parent cancelled too!"); + Switch.on_release sub (fun () -> release "1");; ++release 1 +Exception: +Multiple exceptions: +- Failure("Parent cancelled too!") +- Invalid_argument("Switch finished!"). +- : unit = () +``` + +Using switch from inside release handler: + +```ocaml +# run (fun sw -> + Switch.on_release sw (fun () -> + Fiber.fork ~sw (fun () -> + traceln "Starting release 1"; + Fiber.yield (); + traceln "Finished release 1" + ); + ); + Switch.on_release sw (fun () -> + Fiber.fork ~sw (fun () -> + Switch.on_release sw (fun () -> traceln "Late release"); + traceln "Starting release 2"; + Fiber.yield (); + traceln "Finished release 2" + ); + ); + traceln "Main fiber done" + );; ++Main fiber done ++Starting release 2 ++Starting release 1 ++Finished release 2 ++Finished release 1 ++Late release +- : unit = () +``` + +# Error reporting + +All release hooks run, even if some fail, and all errors are reported: + +```ocaml +# run (fun sw -> + Fiber.fork ~sw (fun () -> try Fiber.await_cancel () with _ -> failwith "cancel1 failed"); + Fiber.fork ~sw (fun () -> try Fiber.await_cancel () with _ -> failwith "cancel2 failed"); + raise Exit + );; +Exception: +Multiple exceptions: +- Stdlib.Exit +- Failure("cancel1 failed") +- Failure("cancel2 failed"). +- : unit = () +``` + +# Errors during cleanup are reported during cancellation + +```ocaml +# run (fun sw -> + Fiber.fork ~sw (fun () -> + Switch.run @@ fun sw -> + try Fiber.await_cancel () with _ -> failwith "cleanup failed"); + Fiber.fork ~sw (fun () -> failwith "simulated error") + );; +Exception: +Multiple exceptions: +- Failure("simulated error") +- Failure("cleanup failed"). +- : unit = () +``` diff --git a/lib_eio_js_backend/tests/sync.md b/lib_eio_js_backend/tests/sync.md new file mode 100644 index 000000000..5c63520b2 --- /dev/null +++ b/lib_eio_js_backend/tests/sync.md @@ -0,0 +1,146 @@ +# Setting up the environment + +```ocaml +# #require "eio_js_backend";; +``` + +```ocaml +open Eio.Std + +module Trace = Eio.Private.Trace + +let pp_promise pp f x = + match Promise.peek x with + | None -> Fmt.string f "unresolved" + | Some Error (Failure msg) -> Fmt.pf f "broken:%s" msg + | Some Error ex -> Fmt.pf f "broken:%a" Fmt.exn ex + | Some Ok x -> Fmt.pf f "fulfilled:%a" pp x +``` + +# Test cases + +Create a promise, fork a thread waiting for it, then fulfull it: +```ocaml +# let () = + Eio_js_backend.start @@ fun _stdenv -> + Switch.run @@ fun sw -> + let p, r = Promise.create () in + traceln "Initial state: %a" (pp_promise Fmt.string) p; + let thread = Fiber.fork_promise ~sw (fun () -> Promise.await_exn p) in + Promise.resolve_ok r "ok"; + traceln "After being fulfilled: %a" (pp_promise Fmt.string) p; + traceln "Thread before yield: %a" (pp_promise Fmt.string) thread; + Fiber.yield (); + traceln "Thread after yield: %a" (pp_promise Fmt.string) thread; + traceln "Final result: %s" (Promise.await_exn thread);; ++Initial state: unresolved ++After being fulfilled: fulfilled:ok ++Thread before yield: unresolved ++Thread after yield: fulfilled:ok ++Final result: ok +``` + +Create a promise, fork a thread waiting for it, then break it: +```ocaml +# let () = + Eio_js_backend.start @@ fun _stdenv -> + Switch.run @@ fun sw -> + let p, r = Promise.create () in + traceln "Initial state: %a" (pp_promise Fmt.string) p; + let thread = Fiber.fork_promise ~sw (fun () -> Promise.await_exn p) in + Promise.resolve_error r (Failure "test"); + traceln "After being broken: %a" (pp_promise Fmt.string) p; + traceln "Thread before yield: %a" (pp_promise Fmt.string) thread; + Fiber.yield (); + traceln "Thread after yield: %a" (pp_promise Fmt.string) thread; + match Promise.await_exn thread with + | x -> failwith x + | exception (Failure msg) -> traceln "Final result exception: %s" msg;; ++Initial state: unresolved ++After being broken: broken:test ++Thread before yield: unresolved ++Thread after yield: broken:test ++Final result exception: test +``` + +Some simple tests of `fork`: +```ocaml +# let () = + Eio_js_backend.start @@ fun _stdenv -> + let i = ref 0 in + Switch.run (fun sw -> + Fiber.fork ~sw (fun () -> incr i); + ); + traceln "Forked code ran; i is now %d" !i; + let p1, r1 = Promise.create () in + try + Switch.run (fun sw -> + Fiber.fork ~sw (fun () -> Promise.await p1; incr i; raise Exit); + traceln "Forked code waiting; i is still %d" !i; + Promise.resolve r1 () + ); + assert false + with Exit -> + traceln "Forked code ran; i is now %d" !i;; ++Forked code ran; i is now 1 ++Forked code waiting; i is still 1 ++Forked code ran; i is now 2 +``` + +Basic semaphore tests: +```ocaml +# let () = + let module Semaphore = Eio.Semaphore in + Eio_js_backend.start @@ fun _stdenv -> + Switch.run @@ fun sw -> + let running = ref 0 in + let sem = Semaphore.make 2 in + let fork = Fiber.fork_promise ~sw in + let a = fork (fun () -> Trace.log "a"; Semaphore.acquire sem; incr running) in + let b = fork (fun () -> Trace.log "b"; Semaphore.acquire sem; incr running) in + let c = fork (fun () -> Trace.log "c"; Semaphore.acquire sem; incr running) in + let d = fork (fun () -> Trace.log "d"; Semaphore.acquire sem; incr running) in + traceln "Semaphore means that only %d threads are running" !running; + Promise.await_exn a; + Promise.await_exn b; + (* a finishes and c starts *) + decr running; + Semaphore.release sem; + traceln "One finished; now %d is running " !running; + Fiber.yield (); + traceln "Yield allows C to start; now %d are running " !running; + Promise.await_exn c; + (* b finishes and d starts *) + decr running; + Semaphore.release sem; + Promise.await_exn d; + decr running; + Semaphore.release sem; + decr running; + Semaphore.release sem;; ++Semaphore means that only 2 threads are running ++One finished; now 1 is running ++Yield allows C to start; now 2 are running +``` + +Releasing a semaphore when no-one is waiting for it: +```ocaml +# let () = + let module Semaphore = Eio.Semaphore in + Eio_js_backend.start @@ fun _stdenv -> + Switch.run @@ fun sw -> + let sem = Semaphore.make 0 in + Semaphore.release sem; (* Release with free-counter *) + traceln "Initial config: %d" (Semaphore.get_value sem); + Fiber.fork ~sw (fun () -> Trace.log "a"; Semaphore.acquire sem); + Fiber.fork ~sw (fun () -> Trace.log "b"; Semaphore.acquire sem); + traceln "A running: %d" (Semaphore.get_value sem); + Semaphore.release sem; (* Release with a non-empty wait-queue *) + traceln "Now b running: %d" (Semaphore.get_value sem); + Semaphore.release sem; (* Release with an empty wait-queue *) + traceln "Finished: %d" (Semaphore.get_value sem);; ++Initial config: 1 ++A running: 0 ++Now b running: 0 ++Finished: 1 +``` diff --git a/lib_eio_js_backend/tests/trace.md b/lib_eio_js_backend/tests/trace.md new file mode 100644 index 000000000..859381b96 --- /dev/null +++ b/lib_eio_js_backend/tests/trace.md @@ -0,0 +1,14 @@ +```ocaml +# #require "eio_js_backend";; +# open Eio.Std;; +# Eio_js_backend.start @@ fun () -> + traceln "One-line trace"; + traceln "@[A nested list@,Foo@,Bar@]"; + traceln "Trace with position" ~__POS__:("trace.md", 5, 1, 10);; ++One-line trace ++A nested list ++ Foo ++ Bar ++Trace with position [trace.md:5] +- : unit = () +``` diff --git a/lib_js_of_ocaml_eio/dune b/lib_js_of_ocaml_eio/dune new file mode 100644 index 000000000..77451b91d --- /dev/null +++ b/lib_js_of_ocaml_eio/dune @@ -0,0 +1,6 @@ +(library + (name js_of_ocaml_eio) + (public_name js_of_ocaml-eio) + (modes byte) + (libraries eio_js_backend js_of_ocaml) + (preprocess (pps js_of_ocaml-ppx))) diff --git a/lib_js_of_ocaml_eio/eio_js.ml b/lib_js_of_ocaml_eio/eio_js.ml new file mode 100644 index 000000000..f3550daab --- /dev/null +++ b/lib_js_of_ocaml_eio/eio_js.ml @@ -0,0 +1,9 @@ +let start = Eio_js_backend.start + +let sleep d = + Eio_js_backend.await + ~setup:(fun ~resolve ~reject:_ -> + Js_of_ocaml.Dom_html.setTimeout resolve (d *. 1000.)) + ~cancel:Js_of_ocaml.Dom_html.clearTimeout + +let yield () = sleep 0. diff --git a/lib_js_of_ocaml_eio/eio_js.mli b/lib_js_of_ocaml_eio/eio_js.mli new file mode 100644 index 000000000..83e0877d2 --- /dev/null +++ b/lib_js_of_ocaml_eio/eio_js.mli @@ -0,0 +1,17 @@ +(** {1 Eio scheduler setup} *) + +val start : (unit -> unit) -> unit +(** [start f] executes function [f] asynchronously in a context where + Eio operations can be performed. + + This function is an alias for {!Eio_js_scheduler.start}. +*) + +(** {1 Javascript specific Eio functions.} *) + +val sleep : float -> unit +(** [sleep d] waits for [d] seconds. *) + +val yield : unit -> unit +(** [yield ()] suspends itself and then resumes as soon as + possible. *) diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/LICENSE b/lib_js_of_ocaml_eio/examples/boulderdash/LICENSE new file mode 100644 index 000000000..c05c5919a --- /dev/null +++ b/lib_js_of_ocaml_eio/examples/boulderdash/LICENSE @@ -0,0 +1,20 @@ + +All files contained in this directory and its sub-directories are +distributed under the terms of the DO WHAT THE FUCK YOU WANT TO PUBLIC +LICENSE (included below). + +------------------------------------------------------------------------ + + DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE + Version 2, December 2004 + + Copyright (C) 2004 Sam Hocevar + 14 rue de Plaisance, 75014 Paris, France + Everyone is permitted to copy and distribute verbatim or modified + copies of this license document, and changing it is allowed as long + as the name is changed. + + DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. You just DO WHAT THE FUCK YOU WANT TO. diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/README b/lib_js_of_ocaml_eio/examples/boulderdash/README new file mode 100644 index 000000000..b3bb50701 --- /dev/null +++ b/lib_js_of_ocaml_eio/examples/boulderdash/README @@ -0,0 +1 @@ +This is a port of the Boulder Dash example from O'Browser. diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/boulderdash.ml b/lib_js_of_ocaml_eio/examples/boulderdash/boulderdash.ml new file mode 100644 index 000000000..1eadc1c52 --- /dev/null +++ b/lib_js_of_ocaml_eio/examples/boulderdash/boulderdash.ml @@ -0,0 +1,476 @@ +(* Js_of_ocaml examples + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2008 Benjamin Canou + * + * DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE + * TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + * + *) + +open Js_of_ocaml +open Js_of_ocaml_eio +module Html = Dom_html + +let js = Js.string +let document = Html.window##.document +let append_text e s = Dom.appendChild e (document##createTextNode (js s)) + +let replace_child p n = + Js.Opt.iter p##.firstChild (fun c -> Dom.removeChild p c); + Dom.appendChild p n + +let box_style = + js + "border: 1px black solid; background-color: white ; display: inline ; \ + padding-right: .5em; padding-left: .5em;" + +let loading_style = + js + "background-color: red; color: white; display:inline; position: absolute; \ + top:0; right:0;" + +let loading parent = + let div = Html.createDiv document in + div##.style##.cssText := loading_style; + append_text div "LOADING..."; + Dom.appendChild parent div; + fun () -> Dom.removeChild parent div + +let clock_div ~sw = + let t0 = ref (Sys.time ()) in + let div = Html.createDiv document in + div##.style##.cssText := box_style; + append_text div "--:--:--"; + let stopped = ref true in + let rec update_cb () = + let dt = Sys.time () -. !t0 in + (if not !stopped then + let str = + let secs = int_of_float dt in + js + (Printf.sprintf "%02d:%02d:%02d" (secs / 3600) + (secs / 60 mod 60) + (secs mod 60)) + in + let txt = document##createTextNode str in + replace_child div txt); + Eio_js.sleep 1.; + update_cb () + in + Eio.Fiber.fork ~sw update_cb; + ( div, + (fun () -> + t0 := Sys.time (); + stopped := false), + fun () -> stopped := true ) + +type cell = Empty | Grass | Diamond | Boulder | Door | End | Guy | Wall | Bam + +and state = { + map : cell array array; + imgs : Html.imageElement Js.t array array; + mutable pos : int * int; + endpos : int * int; + mutable rem : int; + mutable dead : bool; + map_mutex : Eio.Mutex.t; + mutable events_mutex : bool; + pending_out_cb : (unit -> unit) option ref; +} + +exception Death + +let img_assoc v = + match v with + | Empty -> js "sprites/empty.png" + | Bam -> js "sprites/bam.png" + | Grass -> js "sprites/grass.png" + | Diamond -> js "sprites/diamond.png" + | Boulder -> js "sprites/boulder.png" + | End -> js "sprites/end.png" + | Door -> js "sprites/door.png" + | Guy -> js "sprites/guy.png" + | Wall -> js "sprites/wall.png" + +let set_cell state x y v = + state.map.(y).(x) <- v; + state.imgs.(y).(x)##.src := img_assoc v + +let walkable = function Empty | Grass | Diamond | End -> true | _ -> false + +let rec fall state = + (* assumes wall borders *) + let changed = ref false in + for y = Array.length state.map - 2 downto 1 do + for x = 1 to Array.length state.map.(y) - 2 do + let sustaining = + state.map.(y + 1).(x) = Guy && state.map.(y).(x) = Boulder + in + if state.map.(y).(x) = Empty && state.map.(y - 1).(x) = Boulder then ( + set_cell state x (y - 1) Empty; + set_cell state x y Boulder; + changed := true); + if + state.map.(y).(x) = Empty + && state.map.(y - 1).(x) = Empty + && state.map.(y).(x - 1) = Boulder + && state.map.(y - 1).(x - 1) = Boulder + then ( + set_cell state (x - 1) (y - 1) Empty; + set_cell state x y Boulder; + changed := true); + if + state.map.(y).(x) = Empty + && state.map.(y - 1).(x) = Empty + && state.map.(y).(x + 1) = Boulder + && state.map.(y - 1).(x + 1) = Boulder + then ( + set_cell state (x + 1) (y - 1) Empty; + set_cell state x y Boulder; + changed := true); + if + (not sustaining) + && state.map.(y + 1).(x) = Guy + && state.map.(y).(x) = Boulder + then ( + set_cell state x (y + 1) Bam; + raise Death) + done + done; + if !changed then ( + Eio_js.sleep 0.05; + fall state) + +let rec build_interaction state show_rem ((_, _, clock_stop) as clock) = + Eio.Mutex.lock state.map_mutex; + for y = 0 to Array.length state.map - 1 do + for x = 0 to Array.length state.map.(y) - 1 do + state.imgs.(y).(x)##.onmouseover := Html.no_handler; + state.imgs.(y).(x)##.onmouseout := Html.no_handler; + state.imgs.(y).(x)##.onclick := Html.no_handler + done + done; + let inhibit f _x = + if not state.events_mutex then + Eio_js.start (fun () -> + state.events_mutex <- true; + f (); + state.events_mutex <- false); + Js._false + in + let set_pending_out f out () = + f (); + state.pending_out_cb := Some out + in + let with_pending_out f () = + match !(state.pending_out_cb) with + | None -> f () + | Some out -> + out (); + state.pending_out_cb := None; + f () + in + let rec update (x, y) next img over_cont out_cont click_cont = + if walkable state.map.(y).(x) then ( + let cur_img = state.imgs.(y).(x)##.src in + let over () = + state.imgs.(y).(x)##.src := img; + over_cont () + and out () = + state.imgs.(y).(x)##.src := cur_img; + out_cont () + and click' () = + click_cont (); + if state.map.(y).(x) = Diamond then state.rem <- state.rem - 1; + set_cell state x y Guy; + Eio_js.sleep 0.05; + fall state; + set_cell state x y Empty + in + let click () = + let gx, gy = state.pos in + set_cell state gx gy Empty; + let () = + try + click_cont (); + if state.map.(y).(x) = Diamond then state.rem <- state.rem - 1; + set_cell state x y Guy; + state.pos <- (x, y); + fall state + with Death -> state.dead <- true + in + build_interaction state show_rem clock + in + state.imgs.(y).(x)##.onmouseover + := Html.handler (inhibit (set_pending_out (with_pending_out over) out)); + state.imgs.(y).(x)##.onmouseout + := Html.handler (inhibit (with_pending_out (fun () -> ()))); + state.imgs.(y).(x)##.onclick + := Html.handler (inhibit (with_pending_out click)); + if state.map.(y).(x) <> End then + update (next (x, y)) next img over out click') + in + let update_push ((x, y) as pos) next img img_guy = + let ((x', y') as pos') = next pos in + let x'', y'' = next pos' in + if + try state.map.(y').(x') = Boulder && state.map.(y'').(x'') = Empty + with Invalid_argument _ -> false + then ( + let over () = + state.imgs.(y).(x)##.src := img_guy; + state.imgs.(y').(x')##.src := img + in + let out () = + state.imgs.(y).(x)##.src := js "sprites/guy.png"; + state.imgs.(y').(x')##.src := js "sprites/boulder.png" + in + let click () = + set_cell state x y Empty; + set_cell state x' y' Guy; + state.pos <- pos'; + set_cell state x'' y'' Boulder; + let () = try fall state with Death -> state.dead <- true in + build_interaction state show_rem clock + in + state.imgs.(y').(x')##.onmouseover + := Html.handler (inhibit (set_pending_out (with_pending_out over) out)); + state.imgs.(y').(x')##.onmouseout + := Html.handler (inhibit (with_pending_out (fun () -> ()))); + state.imgs.(y').(x')##.onclick + := Html.handler (inhibit (with_pending_out click))) + in + if state.pos = state.endpos then ( + clock_stop (); + Html.window##alert (js "YOU WIN !")) + else if state.dead then ( + clock_stop (); + Html.window##alert (js "YOU LOSE !")) + else ( + if state.rem = 0 then ( + let x, y = state.endpos in + state.imgs.(y).(x)##.src := js "sprites/end.png"; + state.map.(y).(x) <- End); + let r (x, y) = (succ x, y) and l (x, y) = (pred x, y) in + let u (x, y) = (x, pred y) and d (x, y) = (x, succ y) in + let nil_cont () = () in + let nil_cont_async () = () in + update (r state.pos) r (js "sprites/R.png") nil_cont_async nil_cont + nil_cont_async; + update (l state.pos) l (js "sprites/L.png") nil_cont_async nil_cont + nil_cont_async; + update (u state.pos) u (js "sprites/U.png") nil_cont_async nil_cont + nil_cont_async; + update (d state.pos) d (js "sprites/D.png") nil_cont_async nil_cont + nil_cont_async; + update_push state.pos r (js "sprites/bR.png") (js "sprites/push_r.png"); + update_push state.pos l (js "sprites/bL.png") (js "sprites/push_l.png"); + show_rem state.rem); + Eio.Mutex.unlock state.map_mutex + +let opt_style e style = + match style with Some s -> e##.style##.cssText := s | None -> () + +let build_table ?style ?tr_style ?td_style f t = + let m = Html.createTable document in + opt_style m style; + for y = 0 to Array.length t - 1 do + let tr = m##insertRow (-1) in + opt_style tr tr_style; + for x = 0 to Array.length t.(y) - 1 do + let td = tr##insertCell (-1) in + opt_style td td_style; + Dom.appendChild td (f y x t.(y).(x)); + Dom.appendChild tr td + done; + Dom.appendChild m tr + done; + m + +let http_get url = + let r = XmlHttpRequest.get url in + let cod = r.XmlHttpRequest.code in + let msg = r.XmlHttpRequest.content in + if cod = 0 || cod = 200 then msg else assert false + +let getfile f = http_get f + +exception Eos + +let start _ = + Eio.Switch.run @@ fun sw -> + let body = + Js.Opt.get + (document##getElementById (js "boulderdash")) + (fun () -> assert false) + in + let board_div = Html.createDiv document in + let ((clock_div, clock_start, _) as clock) = clock_div ~sw in + let load_data name process = + let loading_end = loading body in + let data = getfile name in + let res = process data in + loading_end (); + res + in + let rem_div, show_rem = + let div = Html.createDiv document in + div##.style##.cssText := box_style; + append_text div "--"; + ( div, + fun v -> + replace_child div + (document##createTextNode (Js.string (string_of_int v))) ) + in + let levels = + load_data "maps.txt" (fun txt -> + let find_string st = + let sz = String.length txt in + let rec find_string_start s = + if s >= sz then raise Eos + else if txt.[s] == '"' then find_string_end (s + 1) (s + 2) + else find_string_start (s + 1) + and find_string_end s e = + if s >= sz then raise Eos + else if txt.[e] == '"' then (String.sub txt s (e - s), e + 1) + else find_string_end s (e + 1) + in + find_string_start st + in + let rec scan_pairs st acc = + match + try + let fst, st = find_string st in + let snd, st = find_string st in + Some ((fst, snd), st) + with Eos -> None + with + | Some (elt, st) -> scan_pairs st (elt :: acc) + | None -> acc + in + List.rev (scan_pairs 0 [])) + in + let load_level file = + load_data file (fun data -> + let map, cells = + let res = ref [] and row = ref [] in + for i = 0 to String.length data - 1 do + match data.[i] with + | '\n' -> + res := List.rev !row :: !res; + row := [] + | '#' -> row := Wall :: !row + | '.' -> row := Grass :: !row + | ' ' -> row := Empty :: !row + | '+' -> row := Diamond :: !row + | 'X' -> row := Boulder :: !row + | 'W' -> row := Guy :: !row + | 'E' -> row := Door :: !row + | 'S' -> row := Guy :: !row + | _ -> failwith "malformed level" + done; + let map = Array.of_list (List.map Array.of_list (List.rev !res)) in + ( map, + Array.map + (Array.map (fun c -> + let img = Html.createImg document in + img##.src := img_assoc c; + img)) + map ) + in + let gx = ref 0 + and gy = ref 0 + and ex = ref 0 + and ey = ref 0 + and rem = ref 0 in + let style = + js + "border-collapse:collapse;line-height: 0; opacity: 0; \ + margin-left:auto; margin-right:auto" + in + let td_style = js "padding: 0; width: 20px; height: 20px;" in + let table = + build_table ~style ~td_style + (fun y x cell -> + (match map.(y).(x) with + | Guy -> + gx := x; + gy := y + | Diamond -> incr rem + | Door -> + ex := x; + ey := y + | _ -> ()); + cell) + cells + in + replace_child board_div table; + build_interaction + { + map; + imgs = cells; + pos = (!gx, !gy); + endpos = (!ex, !ey); + map_mutex = Eio.Mutex.create (); + events_mutex = false; + dead = false; + rem = !rem; + pending_out_cb = ref None; + } + show_rem clock; + let t0 = Sys.time () in + let rec fade () = + let t = Sys.time () in + if t -. t0 >= 1. then table##.style##.opacity := Js.def (js "1") + else ( + Eio_js.sleep 0.05; + table##.style##.opacity + := Js.def (js (Printf.sprintf "%g" (t -. t0))); + fade ()) + in + fade (); + clock_start ()) + in + body##.style##.cssText + := js + "font-family: sans-serif; text-align: center; background-color: #e8e8e8;"; + let h1 = Html.createH1 document in + append_text h1 "Boulder Dash in Ocaml"; + Dom.appendChild body h1; + let div = Html.createDiv document in + append_text div "Elapsed time: "; + Dom.appendChild div clock_div; + append_text div " Remaining diamonds: "; + Dom.appendChild div rem_div; + append_text div " "; + let select = Html.createSelect document in + let option = Html.createOption document in + append_text option "Choose a level"; + Dom.appendChild select option; + List.iter + (fun (_f, n) -> + let option = Html.createOption document in + append_text option n; + (* + option##onclick <- + some (fun _ -> ignore (load_level f); Js._false); +*) + Dom.appendChild select option) + levels; + select##.onchange := + Html.handler (fun _ -> + let i = select##.selectedIndex - 1 in + if i >= 0 && i < List.length levels then + Eio_js.start (fun () -> load_level (fst (List.nth levels i))); + Js._false); + Dom.appendChild div select; + Dom.appendChild div (Html.createBr document); + Dom.appendChild div (Html.createBr document); + Dom.appendChild div board_div; + Dom.appendChild body div + +let _ = + Html.window##.onload := + Html.handler (fun _ -> + Eio_js.start start; + Js._false) diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/boulderdash.mli b/lib_js_of_ocaml_eio/examples/boulderdash/boulderdash.mli new file mode 100644 index 000000000..e69de29bb diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/dune b/lib_js_of_ocaml_eio/examples/boulderdash/dune new file mode 100644 index 000000000..8b6b105a6 --- /dev/null +++ b/lib_js_of_ocaml_eio/examples/boulderdash/dune @@ -0,0 +1,15 @@ +(executables + (names boulderdash) + (libraries js_of_ocaml-eio) + (modes js) + (js_of_ocaml (flags --enable=effects)) + (preprocess + (pps js_of_ocaml-ppx))) + +(alias + (name default) + (deps + index.html + maps.txt + (glob_files maps/*.map) + (glob_files sprites/*.{png,svg}))) diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/index.html b/lib_js_of_ocaml_eio/examples/boulderdash/index.html new file mode 100644 index 000000000..b72f42659 --- /dev/null +++ b/lib_js_of_ocaml_eio/examples/boulderdash/index.html @@ -0,0 +1,12 @@ + + + + + Boulder Dash + + + + + + diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/maps.txt b/lib_js_of_ocaml_eio/examples/boulderdash/maps.txt new file mode 100644 index 000000000..6ab111caa --- /dev/null +++ b/lib_js_of_ocaml_eio/examples/boulderdash/maps.txt @@ -0,0 +1,5 @@ +"maps/level0.map" "Level without boulders" +"maps/level1.map" "Simple falls" +"maps/level2.map" "More falls" +"maps/level3.map" "Real (yet little) puzzle" +"maps/level4.map" "Bigger puzzle (copie de BeeDeeDash)" diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/maps/level0.map b/lib_js_of_ocaml_eio/examples/boulderdash/maps/level0.map new file mode 100644 index 000000000..12934bda4 --- /dev/null +++ b/lib_js_of_ocaml_eio/examples/boulderdash/maps/level0.map @@ -0,0 +1,5 @@ +################### +#S........+.......# +#+....+.........+## +#...+........+.#.E# +################### diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/maps/level1.map b/lib_js_of_ocaml_eio/examples/boulderdash/maps/level1.map new file mode 100644 index 000000000..7c8e87b64 --- /dev/null +++ b/lib_js_of_ocaml_eio/examples/boulderdash/maps/level1.map @@ -0,0 +1,8 @@ +################## +#S X # # +# + #.X..XX....# +# X #.+..++....# +# + # + # +# # XX # +# . +. E# +################## diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/maps/level2.map b/lib_js_of_ocaml_eio/examples/boulderdash/maps/level2.map new file mode 100644 index 000000000..573040efa --- /dev/null +++ b/lib_js_of_ocaml_eio/examples/boulderdash/maps/level2.map @@ -0,0 +1,8 @@ +#################### +#S# XXXXX # +# # XX .XXX. # +# # .XX. .X. # +# # +. + # +# ## XX # +# +X. E# +#################### diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/maps/level3.map b/lib_js_of_ocaml_eio/examples/boulderdash/maps/level3.map new file mode 100644 index 000000000..a601ab921 --- /dev/null +++ b/lib_js_of_ocaml_eio/examples/boulderdash/maps/level3.map @@ -0,0 +1,9 @@ +############## +#XXXX# # +#XXX+# + # +#X..S# X## # +#+ +X+# # +# #X#X# # +# +E.... # +# #++ # +############## diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/maps/level4.map b/lib_js_of_ocaml_eio/examples/boulderdash/maps/level4.map new file mode 100644 index 000000000..d498f9ceb --- /dev/null +++ b/lib_js_of_ocaml_eio/examples/boulderdash/maps/level4.map @@ -0,0 +1,22 @@ +######################################## +#...... ..+.X .....X.X....... ....X....# +#.XSX...... .........X+..X.... ..... ..# +#.......... ..X.....X.X..X........X....# +#X.XX.........X......X..X....X...X.....# +#X. X......... X..X........X......X.XX.# +#... ..X........X.....X. X........X.XX.# +###############################...X..X.# +#. ...X..+. ..X.X..........+.X+...... .# +#..+.....X..... ........XX X..X....X...# +#...X..X.X..............X .X..X........# +#.X.....X........XXX.......X.. .+....X.# +#.+.. ..X. .....X.X+..+....X...X..+. .# +#. X..............X X..X........+.....X# +#........############################### +# X.........X...+....X.....X...X.......# +# X......... X..X........X......X.XX..E# +#. ..X........X.....X. ....+...X.XX...# +#....X+..X........X......X.X+......X...# +#... ..X. ..X.XX.........X.X+...... ..X# +#.+.... ..... ......... .X..X....X...X.# +######################################## diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/D.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/D.png new file mode 100644 index 000000000..bdff85c99 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/D.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/L.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/L.png new file mode 100644 index 000000000..0dc9cb562 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/L.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/R.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/R.png new file mode 100644 index 000000000..aebbad645 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/R.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/U.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/U.png new file mode 100644 index 000000000..2a624c1e9 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/U.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bD.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bD.png new file mode 100644 index 000000000..78aad7154 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bD.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bL.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bL.png new file mode 100644 index 000000000..a73a10494 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bL.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bR.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bR.png new file mode 100644 index 000000000..155f8c8ca Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bR.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bU.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bU.png new file mode 100644 index 000000000..60949768a Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bU.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bam.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bam.png new file mode 100644 index 000000000..acdf1516e Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bam.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/blue_diamond.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/blue_diamond.png new file mode 100644 index 000000000..d48cbdf71 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/blue_diamond.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bomb.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bomb.png new file mode 100644 index 000000000..c73c66fe5 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/bomb.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/boulder.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/boulder.png new file mode 100644 index 000000000..c6e2add2b Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/boulder.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/diamond.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/diamond.png new file mode 100644 index 000000000..5d57cf4d3 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/diamond.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/door.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/door.png new file mode 100644 index 000000000..7668c21ea Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/door.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/empty.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/empty.png new file mode 100644 index 000000000..a5aabfdd0 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/empty.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/end.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/end.png new file mode 100644 index 000000000..b30f49bb4 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/end.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/grass.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/grass.png new file mode 100644 index 000000000..aba8a76a1 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/grass.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/guy.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/guy.png new file mode 100644 index 000000000..c88f46f73 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/guy.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/push_l.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/push_l.png new file mode 100644 index 000000000..5e2cfe2b7 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/push_l.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/push_r.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/push_r.png new file mode 100644 index 000000000..d008a7116 Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/push_r.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/red_diamond.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/red_diamond.png new file mode 100644 index 000000000..7f974d65e Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/red_diamond.png differ diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/scalable.svg b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/scalable.svg new file mode 100644 index 000000000..e27c91a04 --- /dev/null +++ b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/scalable.svg @@ -0,0 +1,974 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/lib_js_of_ocaml_eio/examples/boulderdash/sprites/wall.png b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/wall.png new file mode 100644 index 000000000..f6c96136b Binary files /dev/null and b/lib_js_of_ocaml_eio/examples/boulderdash/sprites/wall.png differ diff --git a/lib_js_of_ocaml_eio/file.ml b/lib_js_of_ocaml_eio/file.ml new file mode 100644 index 000000000..583ce59b6 --- /dev/null +++ b/lib_js_of_ocaml_eio/file.ml @@ -0,0 +1,53 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2011 Pierre Chambart + * Laboratoire PPS - CNRS Université Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Js_of_ocaml +open Js +open Dom +open File + +let read_with_filereader (fileReader : fileReader t constr) kind file = + Eio_js_backend.await + ~setup:(fun ~resolve ~reject:_ -> + let reader = new%js fileReader in + reader##.onloadend := + handler (fun _ -> + if reader##.readyState == DONE then + resolve + (match Opt.to_option (CoerceTo.string reader##.result) with + | None -> + assert false (* can't happen: called with good readAs_ *) + | Some s -> s) + else (); + (* CCC TODO: handle errors *) + Js._false); + (match kind with + | `BinaryString -> reader##readAsBinaryString file + | `Text -> reader##readAsText file + | `Text_withEncoding e -> reader##readAsText_withEncoding file e + | `DataURL -> reader##readAsDataURL file); + reader) + ~cancel:(fun reader -> reader##abort) + +let reader kind file = read_with_filereader fileReader kind file +let readAsBinaryString file = reader `BinaryString file +let readAsText file = reader `Text file +let readAsText_withEncoding file e = reader (`Text_withEncoding e) file +let readAsDataURL file = reader `DataURL file diff --git a/lib_js_of_ocaml_eio/file.mli b/lib_js_of_ocaml_eio/file.mli new file mode 100644 index 000000000..2011ae78f --- /dev/null +++ b/lib_js_of_ocaml_eio/file.mli @@ -0,0 +1,28 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2011 Pierre Chambart + * Laboratoire PPS - CNRS Université Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Js_of_ocaml +open Js +open File + +val readAsBinaryString : #blob t -> js_string t +val readAsText : #blob t -> js_string t +val readAsText_withEncoding : #blob t -> js_string t -> js_string t +val readAsDataURL : #blob t -> js_string t diff --git a/lib_js_of_ocaml_eio/js_events.ml b/lib_js_of_ocaml_eio/js_events.ml new file mode 100644 index 000000000..8c2a377ab --- /dev/null +++ b/lib_js_of_ocaml_eio/js_events.ml @@ -0,0 +1,668 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2010 Vincent Balat + * Laboratoire PPS - CNRS Université Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Js_of_ocaml + +(* +let start_async f = Eio_js_backend.start (fun () -> Eio_js.yield (); f ()) +*) + +let opt_map f = function None -> None | Some x -> Some (f x) + +let make_event event_kind ?use_capture ?passive target = + let el = ref Js.null in + Eio_js_backend.await + ~setup:(fun ~resolve ~reject:_ -> + let cancel () = Js.Opt.iter !el Dom_html.removeEventListener in + el := + Js.some + (Dom.addEventListenerWithOptions + ?capture:(opt_map Js.bool use_capture) + ?passive:(opt_map Js.bool passive) target event_kind + (Dom_html.handler (fun (ev : #Dom_html.event Js.t) -> + cancel (); + resolve ev; + Js.bool true)) + (* true because we do not want to prevent default -> + the user can use the preventDefault function + above. *)); + cancel) + ~cancel:(fun cancel -> cancel ()) + +(* +let catch_cancel f x = + try + f x + with Eio.Cancel.Cancelled _ -> () + +let with_error_log f x = + try + f x + with e -> + Firebug.console##log (Js.string (Printexc.to_string e)) + +let seq_loop evh ?(cancel_handler = false) ?use_capture ?passive target handler = + Eio.Switch.run @@ fun sw -> + let rec aux () = + let e = evh ?use_capture ?passive target in + with_error_log (handler e) sw; + aux () + in + aux () + +let async_loop evh ?use_capture ?passive target handler = + let cancelled = ref false in + let cur = ref (Lwt.fail (Failure "Lwt_js_event")) in + let lt, _lw = Lwt.task () in + Lwt.on_cancel lt (fun () -> + Lwt.cancel !cur; + cancelled := true); + let rec aux () = + if not !cancelled + then ( + let t = evh ?use_capture ?passive target in + cur := t; + t + >>= fun e -> + Lwt.async (fun () -> with_error_log (handler e) lt); + aux ()) + else Lwt.return () + in + Lwt.async (catch_cancel aux); + lt + +let buffered_loop + evh + ?(cancel_handler = false) + ?(cancel_queue = true) + ?use_capture + ?passive + target + handler = + let cancelled = ref false in + let queue = ref [] in + let cur = ref (Lwt.fail (Failure "Lwt_js_event")) in + let cur_handler = ref (Lwt.return ()) in + let lt, _lw = Lwt.task () in + let spawn = Lwt_condition.create () in + Lwt.on_cancel lt (fun () -> + Lwt.cancel !cur; + if cancel_handler then Lwt.cancel !cur_handler; + if cancel_queue then queue := []; + cancelled := true); + let rec spawner () = + if not !cancelled + then ( + let t = evh ?use_capture ?passive target in + cur := t; + t + >>= fun e -> + queue := e :: !queue; + Lwt_condition.signal spawn (); + spawner ()) + else Lwt.return () + in + let rec runner () = + cur_handler := Lwt.return (); + if not !cancelled + then ( + match !queue with + | [] -> Lwt_condition.wait spawn >>= runner + | e :: tl -> + queue := tl; + cur_handler := with_error_log (handler e) lt; + !cur_handler >>= runner) + else Lwt.return () + in + Lwt.async (catch_cancel spawner); + Lwt.async runner; + lt + +let func_limited_loop event limited_func ?use_capture ?passive target handler = + let count = ref 0 in + async_loop event ?use_capture ?passive target (fun ev lt -> + incr count; + let nb = !count in + limited_func () >>= fun _ -> if !count = nb then handler ev lt else Lwt.return ()) + +let limited_loop event ?(elapsed_time = 0.1) = + func_limited_loop event (fun () -> Lwt_js.sleep elapsed_time) +*) + +let click ?use_capture ?passive target = + make_event Dom_html.Event.click ?use_capture ?passive target + +let copy ?use_capture ?passive target = + make_event Dom_html.Event.copy ?use_capture ?passive target + +let cut ?use_capture ?passive target = + make_event Dom_html.Event.cut ?use_capture ?passive target + +let paste ?use_capture ?passive target = + make_event Dom_html.Event.paste ?use_capture ?passive target + +let dblclick ?use_capture ?passive target = + make_event Dom_html.Event.dblclick ?use_capture ?passive target + +let mousedown ?use_capture ?passive target = + make_event Dom_html.Event.mousedown ?use_capture ?passive target + +let mouseup ?use_capture ?passive target = + make_event Dom_html.Event.mouseup ?use_capture ?passive target + +let mouseover ?use_capture ?passive target = + make_event Dom_html.Event.mouseover ?use_capture ?passive target + +let mousemove ?use_capture ?passive target = + make_event Dom_html.Event.mousemove ?use_capture ?passive target + +let mouseout ?use_capture ?passive target = + make_event Dom_html.Event.mouseout ?use_capture ?passive target + +let keypress ?use_capture ?passive target = + make_event Dom_html.Event.keypress ?use_capture ?passive target + +let keydown ?use_capture ?passive target = + make_event Dom_html.Event.keydown ?use_capture ?passive target + +let keyup ?use_capture ?passive target = + make_event Dom_html.Event.keyup ?use_capture ?passive target + +let change ?use_capture ?passive target = + make_event Dom_html.Event.change ?use_capture ?passive target + +let input ?use_capture ?passive target = + make_event Dom_html.Event.input ?use_capture ?passive target + +let timeupdate ?use_capture ?passive target = + make_event Dom_html.Event.timeupdate ?use_capture ?passive target + +let dragstart ?use_capture ?passive target = + make_event Dom_html.Event.dragstart ?use_capture ?passive target + +let dragend ?use_capture ?passive target = + make_event Dom_html.Event.dragend ?use_capture ?passive target + +let dragenter ?use_capture ?passive target = + make_event Dom_html.Event.dragenter ?use_capture ?passive target + +let dragover ?use_capture ?passive target = + make_event Dom_html.Event.dragover ?use_capture ?passive target + +let dragleave ?use_capture ?passive target = + make_event Dom_html.Event.dragleave ?use_capture ?passive target + +let drag ?use_capture ?passive target = + make_event Dom_html.Event.drag ?use_capture ?passive target + +let drop ?use_capture ?passive target = + make_event Dom_html.Event.drop ?use_capture ?passive target + +let focus ?use_capture ?passive target = + make_event Dom_html.Event.focus ?use_capture ?passive target + +let blur ?use_capture ?passive target = + make_event Dom_html.Event.blur ?use_capture ?passive target + +let scroll ?use_capture ?passive target = + make_event Dom_html.Event.scroll ?use_capture ?passive target + +let submit ?use_capture ?passive target = + make_event Dom_html.Event.submit ?use_capture ?passive target + +let select ?use_capture ?passive target = + make_event Dom_html.Event.select ?use_capture ?passive target + +let abort ?use_capture ?passive target = + make_event Dom_html.Event.abort ?use_capture ?passive target + +let error ?use_capture ?passive target = + make_event Dom_html.Event.error ?use_capture ?passive target + +let load ?use_capture ?passive target = + make_event Dom_html.Event.load ?use_capture ?passive target + +let canplay ?use_capture ?passive target = + make_event Dom_html.Event.canplay ?use_capture ?passive target + +let canplaythrough ?use_capture ?passive target = + make_event Dom_html.Event.canplaythrough ?use_capture ?passive target + +let durationchange ?use_capture ?passive target = + make_event Dom_html.Event.durationchange ?use_capture ?passive target + +let emptied ?use_capture ?passive target = + make_event Dom_html.Event.emptied ?use_capture ?passive target + +let ended ?use_capture ?passive target = + make_event Dom_html.Event.ended ?use_capture ?passive target + +let loadeddata ?use_capture ?passive target = + make_event Dom_html.Event.loadeddata ?use_capture ?passive target + +let loadedmetadata ?use_capture ?passive target = + make_event Dom_html.Event.loadedmetadata ?use_capture ?passive target + +let loadstart ?use_capture ?passive target = + make_event Dom_html.Event.loadstart ?use_capture ?passive target + +let pause ?use_capture ?passive target = + make_event Dom_html.Event.pause ?use_capture ?passive target + +let play ?use_capture ?passive target = + make_event Dom_html.Event.play ?use_capture ?passive target + +let playing ?use_capture ?passive target = + make_event Dom_html.Event.playing ?use_capture ?passive target + +let ratechange ?use_capture ?passive target = + make_event Dom_html.Event.ratechange ?use_capture ?passive target + +let seeked ?use_capture ?passive target = + make_event Dom_html.Event.seeked ?use_capture ?passive target + +let seeking ?use_capture ?passive target = + make_event Dom_html.Event.seeking ?use_capture ?passive target + +let stalled ?use_capture ?passive target = + make_event Dom_html.Event.stalled ?use_capture ?passive target + +let suspend ?use_capture ?passive target = + make_event Dom_html.Event.suspend ?use_capture ?passive target + +let volumechange ?use_capture ?passive target = + make_event Dom_html.Event.volumechange ?use_capture ?passive target + +let waiting ?use_capture ?passive target = + make_event Dom_html.Event.waiting ?use_capture ?passive target + +(* special case for mousewheel, because it depends on the browser *) +let mousewheel ?use_capture ?passive target = + Eio_js_backend.await + ~setup:(fun ~resolve ~reject:_ -> + let el = ref Js.null in + let cancel () = Js.Opt.iter !el Dom_html.removeEventListener in + el := + Js.some + (Dom_html.addMousewheelEventListenerWithOptions + ?capture:(opt_map Js.bool use_capture) + ?passive:(opt_map Js.bool passive) target + (fun (ev : #Dom_html.event Js.t) ~dx ~dy -> + Firebug.console##log ev; + cancel (); + resolve (ev, (dx, dy)); + Js.bool true) + (* true because we do not want to prevent default -> + the user can use the preventDefault function + above. *)); + cancel) + ~cancel:(fun cancel -> cancel ()) + +let wheel ?use_capture ?passive target = + make_event Dom_html.Event.wheel ?use_capture ?passive target + +let touchstart ?use_capture ?passive target = + make_event Dom_html.Event.touchstart ?use_capture ?passive target + +let touchmove ?use_capture ?passive target = + make_event Dom_html.Event.touchmove ?use_capture ?passive target + +let touchend ?use_capture ?passive target = + make_event Dom_html.Event.touchend ?use_capture ?passive target + +let touchcancel ?use_capture ?passive target = + make_event Dom_html.Event.touchcancel ?use_capture ?passive target + +let lostpointercapture ?use_capture ?passive target = + make_event Dom_html.Event.lostpointercapture ?use_capture ?passive target + +let gotpointercapture ?use_capture ?passive target = + make_event Dom_html.Event.gotpointercapture ?use_capture ?passive target + +let pointerenter ?use_capture ?passive target = + make_event Dom_html.Event.pointerenter ?use_capture ?passive target + +let pointercancel ?use_capture ?passive target = + make_event Dom_html.Event.pointercancel ?use_capture ?passive target + +let pointerdown ?use_capture ?passive target = + make_event Dom_html.Event.pointerdown ?use_capture ?passive target + +let pointerleave ?use_capture ?passive target = + make_event Dom_html.Event.pointerleave ?use_capture ?passive target + +let pointermove ?use_capture ?passive target = + make_event Dom_html.Event.pointermove ?use_capture ?passive target + +let pointerout ?use_capture ?passive target = + make_event Dom_html.Event.pointerout ?use_capture ?passive target + +let pointerover ?use_capture ?passive target = + make_event Dom_html.Event.pointerover ?use_capture ?passive target + +let pointerup ?use_capture ?passive target = + make_event Dom_html.Event.pointerup ?use_capture ?passive target + +let transitionend ?use_capture ?passive elt = + make_event Dom_html.Event.transitionend ?use_capture ?passive elt + +let transitionstart ?use_capture ?passive elt = + make_event Dom_html.Event.transitionstart ?use_capture ?passive elt + +let transitionrun ?use_capture ?passive elt = + make_event Dom_html.Event.transitionrun ?use_capture ?passive elt + +let transitioncancel ?use_capture ?passive elt = + make_event Dom_html.Event.transitioncancel ?use_capture ?passive elt + +(* +let clicks ?cancel_handler ?use_capture ?passive t = + seq_loop click ?cancel_handler ?use_capture ?passive t + +let copies ?cancel_handler ?use_capture ?passive t = + seq_loop copy ?cancel_handler ?use_capture ?passive t + +let cuts ?cancel_handler ?use_capture ?passive t = + seq_loop cut ?cancel_handler ?use_capture ?passive t + +let pastes ?cancel_handler ?use_capture ?passive t = + seq_loop paste ?cancel_handler ?use_capture ?passive t + +let dblclicks ?cancel_handler ?use_capture ?passive t = + seq_loop dblclick ?cancel_handler ?use_capture ?passive t + +let mousedowns ?cancel_handler ?use_capture ?passive t = + seq_loop mousedown ?cancel_handler ?use_capture ?passive t + +let mouseups ?cancel_handler ?use_capture ?passive t = + seq_loop mouseup ?cancel_handler ?use_capture ?passive t + +let mouseovers ?cancel_handler ?use_capture ?passive t = + seq_loop mouseover ?cancel_handler ?use_capture ?passive t + +let mousemoves ?cancel_handler ?use_capture ?passive t = + seq_loop mousemove ?cancel_handler ?use_capture ?passive t + +let mouseouts ?cancel_handler ?use_capture ?passive t = + seq_loop mouseout ?cancel_handler ?use_capture ?passive t + +let keypresses ?cancel_handler ?use_capture ?passive t = + seq_loop keypress ?cancel_handler ?use_capture ?passive t + +let keydowns ?cancel_handler ?use_capture ?passive t = + seq_loop keydown ?cancel_handler ?use_capture ?passive t + +let keyups ?cancel_handler ?use_capture ?passive t = + seq_loop keyup ?cancel_handler ?use_capture ?passive t + +let changes ?cancel_handler ?use_capture ?passive t = + seq_loop change ?cancel_handler ?use_capture ?passive t + +let inputs ?cancel_handler ?use_capture ?passive t = + seq_loop input ?cancel_handler ?use_capture ?passive t + +let timeupdates ?cancel_handler ?use_capture ?passive t = + seq_loop timeupdate ?cancel_handler ?use_capture ?passive t + +let dragstarts ?cancel_handler ?use_capture ?passive t = + seq_loop dragstart ?cancel_handler ?use_capture ?passive t + +let dragends ?cancel_handler ?use_capture ?passive t = + seq_loop dragend ?cancel_handler ?use_capture ?passive t + +let dragenters ?cancel_handler ?use_capture ?passive t = + seq_loop dragenter ?cancel_handler ?use_capture ?passive t + +let dragovers ?cancel_handler ?use_capture ?passive t = + seq_loop dragover ?cancel_handler ?use_capture ?passive t + +let dragleaves ?cancel_handler ?use_capture ?passive t = + seq_loop dragleave ?cancel_handler ?use_capture ?passive t + +let drags ?cancel_handler ?use_capture ?passive t = + seq_loop drag ?cancel_handler ?use_capture ?passive t + +let drops ?cancel_handler ?use_capture ?passive t = + seq_loop drop ?cancel_handler ?use_capture ?passive t + +let mousewheels ?cancel_handler ?use_capture ?passive t = + seq_loop mousewheel ?cancel_handler ?use_capture ?passive t + +let wheels ?cancel_handler ?use_capture ?passive t = + seq_loop wheel ?cancel_handler ?use_capture ?passive t + +let touchstarts ?cancel_handler ?use_capture ?passive t = + seq_loop touchstart ?cancel_handler ?use_capture ?passive t + +let touchmoves ?cancel_handler ?use_capture ?passive t = + seq_loop touchmove ?cancel_handler ?use_capture ?passive t + +let touchends ?cancel_handler ?use_capture ?passive t = + seq_loop touchend ?cancel_handler ?use_capture ?passive t + +let touchcancels ?cancel_handler ?use_capture ?passive t = + seq_loop touchcancel ?cancel_handler ?use_capture ?passive t + +let focuses ?cancel_handler ?use_capture ?passive t = + seq_loop focus ?cancel_handler ?use_capture ?passive t + +let blurs ?cancel_handler ?use_capture ?passive t = + seq_loop blur ?cancel_handler ?use_capture ?passive t + +let scrolls ?cancel_handler ?use_capture ?passive t = + seq_loop scroll ?cancel_handler ?use_capture ?passive t + +let submits ?cancel_handler ?use_capture ?passive t = + seq_loop submit ?cancel_handler ?use_capture ?passive t + +let selects ?cancel_handler ?use_capture ?passive t = + seq_loop select ?cancel_handler ?use_capture ?passive t + +let aborts ?cancel_handler ?use_capture ?passive t = + seq_loop abort ?cancel_handler ?use_capture ?passive t + +let errors ?cancel_handler ?use_capture ?passive t = + seq_loop error ?cancel_handler ?use_capture ?passive t + +let loads ?cancel_handler ?use_capture ?passive t = + seq_loop load ?cancel_handler ?use_capture ?passive t + +let canplays ?cancel_handler ?use_capture ?passive t = + seq_loop canplay ?cancel_handler ?use_capture ?passive t + +let canplaythroughs ?cancel_handler ?use_capture ?passive t = + seq_loop canplaythrough ?cancel_handler ?use_capture ?passive t + +let durationchanges ?cancel_handler ?use_capture ?passive t = + seq_loop durationchange ?cancel_handler ?use_capture ?passive t + +let emptieds ?cancel_handler ?use_capture ?passive t = + seq_loop emptied ?cancel_handler ?use_capture ?passive t + +let endeds ?cancel_handler ?use_capture ?passive t = + seq_loop ended ?cancel_handler ?use_capture ?passive t + +let loadeddatas ?cancel_handler ?use_capture ?passive t = + seq_loop loadeddata ?cancel_handler ?use_capture ?passive t + +let loadedmetadatas ?cancel_handler ?use_capture ?passive t = + seq_loop loadedmetadata ?cancel_handler ?use_capture ?passive t + +let loadstarts ?cancel_handler ?use_capture ?passive t = + seq_loop loadstart ?cancel_handler ?use_capture ?passive t + +let pauses ?cancel_handler ?use_capture ?passive t = + seq_loop pause ?cancel_handler ?use_capture ?passive t + +let plays ?cancel_handler ?use_capture ?passive t = + seq_loop play ?cancel_handler ?use_capture ?passive t + +let playings ?cancel_handler ?use_capture ?passive t = + seq_loop playing ?cancel_handler ?use_capture ?passive t + +let ratechanges ?cancel_handler ?use_capture ?passive t = + seq_loop ratechange ?cancel_handler ?use_capture ?passive t + +let seekeds ?cancel_handler ?use_capture ?passive t = + seq_loop seeked ?cancel_handler ?use_capture ?passive t + +let seekings ?cancel_handler ?use_capture ?passive t = + seq_loop seeking ?cancel_handler ?use_capture ?passive t + +let stalleds ?cancel_handler ?use_capture ?passive t = + seq_loop stalled ?cancel_handler ?use_capture ?passive t + +let suspends ?cancel_handler ?use_capture ?passive t = + seq_loop suspend ?cancel_handler ?use_capture ?passive t + +let volumechanges ?cancel_handler ?use_capture ?passive t = + seq_loop volumechange ?cancel_handler ?use_capture ?passive t + +let waitings ?cancel_handler ?use_capture ?passive t = + seq_loop waiting ?cancel_handler ?use_capture ?passive t + +let lostpointercaptures ?cancel_handler ?use_capture ?passive t = + seq_loop lostpointercapture ?cancel_handler ?use_capture ?passive t + +let gotpointercaptures ?cancel_handler ?use_capture ?passive t = + seq_loop gotpointercapture ?cancel_handler ?use_capture ?passive t + +let pointerenters ?cancel_handler ?use_capture ?passive t = + seq_loop pointerenter ?cancel_handler ?use_capture ?passive t + +let pointercancels ?cancel_handler ?use_capture ?passive t = + seq_loop pointercancel ?cancel_handler ?use_capture ?passive t + +let pointerdowns ?cancel_handler ?use_capture ?passive t = + seq_loop pointerdown ?cancel_handler ?use_capture ?passive t + +let pointerleaves ?cancel_handler ?use_capture ?passive t = + seq_loop pointerleave ?cancel_handler ?use_capture ?passive t + +let pointermoves ?cancel_handler ?use_capture ?passive t = + seq_loop pointermove ?cancel_handler ?use_capture ?passive t + +let pointerouts ?cancel_handler ?use_capture ?passive t = + seq_loop pointerout ?cancel_handler ?use_capture ?passive t + +let pointerovers ?cancel_handler ?use_capture ?passive t = + seq_loop pointerover ?cancel_handler ?use_capture ?passive t + +let pointerups ?cancel_handler ?use_capture ?passive t = + seq_loop pointerup ?cancel_handler ?use_capture ?passive t + +let transitionends ?cancel_handler ?use_capture ?passive t = + seq_loop transitionend ?cancel_handler ?use_capture ?passive t + +let transitionstarts ?cancel_handler ?use_capture ?passive t = + seq_loop transitionstart ?cancel_handler ?use_capture ?passive t + +let transitionruns ?cancel_handler ?use_capture ?passive t = + seq_loop transitionrun ?cancel_handler ?use_capture ?passive t + +let transitioncancels ?cancel_handler ?use_capture ?passive t = + seq_loop transitioncancel ?cancel_handler ?use_capture ?passive t +*) + +let request_animation_frame () = + Eio_js_backend.await + ~setup:(fun ~resolve ~reject:_ -> + Dom_html.window##requestAnimationFrame + (Js.wrap_callback (fun (_ : float) -> resolve ()))) + ~cancel:(fun id -> Dom_html.window##cancelAnimationFrame id) + +let onload () = make_event Dom_html.Event.load Dom_html.window + +(* +let domContentLoaded = + let complete = Js.string "complete" in + let doc = Dom_html.window##.document in + fun () -> + if doc##.readyState != complete + then + let t, w = Lwt.task () in + let wakeup w _ = if Lwt.is_sleeping t then Lwt.wakeup w () in + let wakeup_exn w e = if Lwt.is_sleeping t then Lwt.wakeup_exn w e in + (* https://github.com/dperini/ContentLoaded/blob/master/src/contentloaded.js *) + let regular = make_event Dom_html.Event.domContentLoaded doc in + Lwt.on_any regular (wakeup w) (wakeup_exn w); + (* ie8 *) + let readystatechange = + async_loop + (make_event (Dom.Event.make "readystatechange")) + doc + (fun e _ -> + if doc##.readyState == complete then wakeup w e; + Lwt.return_unit) + in + (* fallback, just in case *) + let init = make_event Dom_html.Event.load Dom_html.window in + Lwt.on_any init (wakeup w) (wakeup_exn w); + (* clean and return *) + Lwt.bind t (fun _e -> + Lwt.cancel regular; + Lwt.cancel readystatechange; + Lwt.cancel init; + Lwt.return_unit) +*) + +let onunload () = make_event Dom_html.Event.unload Dom_html.window +let onbeforeunload () = make_event Dom_html.Event.beforeunload Dom_html.window +let onresize () = make_event Dom_html.Event.resize Dom_html.window + +let onorientationchange () = + make_event Dom_html.Event.orientationchange Dom_html.window + +let onpopstate () = make_event Dom_html.Event.popstate Dom_html.window +let onhashchange () = make_event Dom_html.Event.hashchange Dom_html.window + +let onorientationchange_or_onresize () = + Eio.Fiber.first onresize onorientationchange + +(* +let onresizes t = seq_loop (fun ?use_capture:_ ?passive:_ () -> onresize ()) () t + +let onorientationchanges t = + seq_loop (fun ?use_capture:_ ?passive:_ () -> onorientationchange ()) () t + +let onpopstates t = seq_loop (fun ?use_capture:_ ?passive:_ () -> onpopstate ()) () t + +let onhashchanges t = seq_loop (fun ?use_capture:_ ?passive:_ () -> onhashchange ()) () t + +let onorientationchanges_or_onresizes t = + seq_loop (fun ?use_capture:_ ?passive:_ () -> onorientationchange_or_onresize ()) () t + +let limited_onresizes ?elapsed_time t = + limited_loop (fun ?use_capture:_ ?passive:_ () -> onresize ()) ?elapsed_time () t + +let limited_onorientationchanges ?elapsed_time t = + limited_loop + (fun ?use_capture:_ ?passive:_ () -> onorientationchange ()) + ?elapsed_time + () + t + +let limited_onorientationchanges_or_onresizes ?elapsed_time t = + limited_loop + (fun ?use_capture:_ ?passive:_ () -> onorientationchange_or_onresize ()) + ?elapsed_time + () + t +*) diff --git a/lib_js_of_ocaml_eio/js_events.mli b/lib_js_of_ocaml_eio/js_events.mli new file mode 100644 index 000000000..2bf9d19c7 --- /dev/null +++ b/lib_js_of_ocaml_eio/js_events.mli @@ -0,0 +1,1191 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2010 Vincent Balat + * Laboratoire PPS - CNRS Université Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +(** Programming mouse or keyboard events handlers using Lwt *) + +open Js_of_ocaml + +(** + Reminder: + Event capturing starts with the outer most element in the DOM and + works inwards to the HTML element the event took place on (capture phase) + and then out again (bubbling phase). + + Examples of use: + + Waiting for a click on [elt1] before continuing: + + {[Eio_js_events.click elt1]} + + Defining a thread that waits for ESC key on an element: + + {[let rec esc elt = + let ev = keydown elt in + if ev##.keyCode = 27 + then Lwt.return ev + else esc elt]} + + {2 Create Eio fibers for events} *) + +val make_event : + (#Dom_html.event as 'a) Js.t Dom_html.Event.typ -> + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + 'a Js.t +(** [make_event ev target] creates an Eio fiber that waits + for the event [ev] to happen on [target] (once). + This thread isa cancellable. + If you set the optional parameter [~use_capture:true], + the event will be caught during the capture phase, + otherwise it is caught during the bubbling phase + (default). + If you set the optional parameter [~passive:true], + the user agent will ignore [preventDefault] calls + inside the event callback. +*) + +(* +val seq_loop : + (?use_capture:bool -> ?passive:bool -> 'target -> 'event) + -> ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> 'target + -> ('event -> unit Lwt.t -> unit Lwt.t) + -> unit +(** [seq_loop (make_event ev) target handler] creates a looping Lwt + thread that waits for the event [ev] to happen on [target], then + execute handler, and start again waiting for the event. Events + happening during the execution of the handler are ignored. See + [async_loop] and [buffered_loop] for alternative semantics. + + For example, the [clicks] function below is defined by: + + [let clicks ?use_capture ?passive t = seq_loop click ?use_capture ?passive t] + + The thread returned is cancellable using [Lwt.cancel]. + In order for the loop thread to be canceled from within the handler, + the latter receives the former as its second parameter. + + By default, cancelling the loop will not cancel the potential + currently running handler. This behaviour can be changed by + setting the [cancel_handler] parameter to true. +*) + +val async_loop : + (?use_capture:bool -> ?passive:bool -> 'target -> 'event) + -> ?use_capture:bool + -> ?passive:bool + -> 'target + -> ('event -> unit Lwt.t -> unit Lwt.t) + -> unit +(** [async_loop] is similar to [seq_loop], but each handler runs + independently. No event is thus missed, but since several + instances of the handler can be run concurrently, it is up to the + programmer to ensure that they interact correctly. + + Cancelling the loop will not cancel the potential currently running + handlers. +*) + +val buffered_loop : + (?use_capture:bool -> ?passive:bool -> 'target -> 'event) + -> ?cancel_handler:bool + -> ?cancel_queue:bool + -> ?use_capture:bool + -> ?passive:bool + -> 'target + -> ('event -> unit Lwt.t -> unit Lwt.t) + -> unit +(** [buffered_loop] is similar to [seq_loop], but any event that + occurs during an execution of the handler is queued instead of + being ignored. + + No event is thus missed, but there can be a non predictable delay + between its trigger and its treatment. It is thus a good idea to + use this loop with handlers whose running time is short, so the + memorized event still makes sense when the handler is eventually + executed. It is also up to the programmer to ensure that event + handlers terminate so the queue will eventually be emptied. + + By default, cancelling the loop will not cancel the (potential) + currently running handler, but any other queued event will be + dropped. This behaviour can be customized using the two optional + parameters [cancel_handler] and [cancel_queue]. +*) + +val start_async : (unit -> unit) -> unit +(** [async t] records a thread to be executed later. + It is implemented by calling yield, then Lwt.async. + This is useful if you want to create a new event listener + when you are inside an event handler. + This avoids the current event to be caught by the new event handler + (if it propagates). +*) +*) + +(* +val func_limited_loop : + (?use_capture:bool -> ?passive:bool -> 'a -> 'b Lwt.t) + -> (unit -> 'a Lwt.t) + -> ?use_capture:bool + -> ?passive:bool + -> 'a + -> ('b -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t +(** [func_limited_loop event delay_fun target handler] will behave like + [Lwt_js_events.async_loop event target handler] but it will run [delay_fun] + first, and execute [handler] only when [delay_fun] is finished and + no other event occurred in the meantime. + + This allows to limit the number of events caught. + + Be careful, it is an asynchrone loop, so if you give too little time, + several instances of your handler could be run in same time **) + +val limited_loop : + (?use_capture:bool -> ?passive:bool -> 'a -> 'b Lwt.t) + -> ?elapsed_time:float + -> ?use_capture:bool + -> ?passive:bool + -> 'a + -> ('b -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t +(** Same as func_limited_loop but take time instead of function + By default elapsed_time = 0.1s = 100ms **) +*) + +(** {2 Predefined functions for some types of events} *) + +val click : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.mouseEvent Js.t + +val copy : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.clipboardEvent Js.t + +val cut : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.clipboardEvent Js.t + +val paste : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.clipboardEvent Js.t + +val dblclick : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.mouseEvent Js.t + +val mousedown : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.mouseEvent Js.t + +val mouseup : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.mouseEvent Js.t + +val mouseover : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.mouseEvent Js.t + +val mousemove : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.mouseEvent Js.t + +val mouseout : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.mouseEvent Js.t + +val keypress : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.keyboardEvent Js.t + +val keydown : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.keyboardEvent Js.t + +val keyup : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.keyboardEvent Js.t + +val input : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val timeupdate : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val change : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val dragstart : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.dragEvent Js.t + +val dragend : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.dragEvent Js.t + +val dragenter : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.dragEvent Js.t + +val dragover : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.dragEvent Js.t + +val dragleave : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.dragEvent Js.t + +val drag : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.dragEvent Js.t + +val drop : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.dragEvent Js.t + +val focus : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.focusEvent Js.t + +val blur : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.focusEvent Js.t + +val scroll : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val submit : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.submitEvent Js.t + +val select : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val mousewheel : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.mouseEvent Js.t * (int * int) +(** This function returns the event, + together with the numbers of ticks the mouse wheel moved. + Positive means down or right. + This interface is compatible with all (recent) browsers. *) + +val wheel : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.mousewheelEvent Js.t + +val touchstart : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.touchEvent Js.t + +val touchmove : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.touchEvent Js.t + +val touchend : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.touchEvent Js.t + +val touchcancel : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.touchEvent Js.t + +val lostpointercapture : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.pointerEvent Js.t + +val gotpointercapture : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.pointerEvent Js.t + +val pointerenter : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.pointerEvent Js.t + +val pointercancel : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.pointerEvent Js.t + +val pointerdown : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.pointerEvent Js.t + +val pointerleave : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.pointerEvent Js.t + +val pointermove : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.pointerEvent Js.t + +val pointerout : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.pointerEvent Js.t + +val pointerover : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.pointerEvent Js.t + +val pointerup : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.pointerEvent Js.t + +val transitionend : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.transitionEvent Js.t +(** Returns when a CSS transition terminates on the element. *) + +val transitionstart : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.transitionEvent Js.t + +val transitionrun : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.transitionEvent Js.t + +val transitioncancel : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.transitionEvent Js.t + +val load : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.imageElement Js.t -> + Dom_html.event Js.t + +val error : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.imageElement Js.t -> + Dom_html.event Js.t + +val abort : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.imageElement Js.t -> + Dom_html.event Js.t + +val canplay : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val canplaythrough : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val durationchange : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val emptied : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val ended : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val loadeddata : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val loadedmetadata : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val loadstart : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val pause : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val play : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val playing : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val ratechange : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val seeked : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val seeking : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val stalled : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val suspend : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val volumechange : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +val waiting : + ?use_capture:bool -> + ?passive:bool -> + #Dom_html.eventTarget Js.t -> + Dom_html.event Js.t + +(* +val clicks : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val copies : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.clipboardEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val cuts : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.clipboardEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val pastes : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.clipboardEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val dblclicks : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val mousedowns : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val mouseups : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val mouseovers : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val mousemoves : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val mouseouts : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.mouseEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val keypresses : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.keyboardEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val keydowns : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.keyboardEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val keyups : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.keyboardEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val inputs : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val timeupdates : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val changes : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val dragstarts : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val dragends : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val dragenters : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val dragovers : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val dragleaves : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val drags : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val drops : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.dragEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val mousewheels : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.mouseEvent Js.t * (int * int) -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val wheels : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.mousewheelEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val touchstarts : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.touchEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val touchmoves : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.touchEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val touchends : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.touchEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val touchcancels : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.touchEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val focuses : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.focusEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val blurs : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.focusEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val scrolls : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val submits : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.submitEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val selects : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val loads : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.imageElement Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val errors : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.imageElement Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val aborts : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.imageElement Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val canplays : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val canplaythroughs : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val durationchanges : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val emptieds : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val endeds : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val loadeddatas : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val loadedmetadatas : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val loadstarts : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val pauses : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val plays : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val playings : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val ratechanges : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val seekeds : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val seekings : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val stalleds : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val suspends : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val volumechanges : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val waitings : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val lostpointercaptures : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.pointerEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val gotpointercaptures : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.pointerEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val pointerenters : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.pointerEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val pointercancels : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.pointerEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val pointerdowns : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.pointerEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val pointerleaves : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.pointerEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val pointermoves : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.pointerEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val pointerouts : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.pointerEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val pointerovers : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.pointerEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val pointerups : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.pointerEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val transitionends : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.transitionEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val transitionstarts : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.transitionEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val transitionruns : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.transitionEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t + +val transitioncancels : + ?cancel_handler:bool + -> ?use_capture:bool + -> ?passive:bool + -> #Dom_html.eventTarget Js.t + -> (Dom_html.transitionEvent Js.t -> unit Lwt.t -> unit Lwt.t) + -> unit Lwt.t +*) + +val request_animation_frame : unit -> unit +(** Returns when a repaint of the window by the browser starts. + (see JS method [window.requestAnimationFrame]) *) + +val onload : unit -> Dom_html.event Js.t +(** Returns when the page is loaded *) + +(* +val domContentLoaded : unit -> unit +*) + +val onunload : unit -> Dom_html.event Js.t +val onbeforeunload : unit -> Dom_html.event Js.t +val onresize : unit -> Dom_html.event Js.t +val onorientationchange : unit -> Dom_html.event Js.t +val onpopstate : unit -> Dom_html.popStateEvent Js.t +val onhashchange : unit -> Dom_html.hashChangeEvent Js.t +val onorientationchange_or_onresize : unit -> Dom_html.event Js.t + +(* +val onresizes : (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t + +val onorientationchanges : (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t + +val onpopstates : (Dom_html.popStateEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t + +val onhashchanges : + (Dom_html.hashChangeEvent Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t + +val onorientationchanges_or_onresizes : + (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t + +val limited_onresizes : + ?elapsed_time:float -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t + +val limited_onorientationchanges : + ?elapsed_time:float -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t + +val limited_onorientationchanges_or_onresizes : + ?elapsed_time:float -> (Dom_html.event Js.t -> unit Lwt.t -> unit Lwt.t) -> unit Lwt.t +*) diff --git a/lib_js_of_ocaml_eio/js_of_ocaml_eio.ml b/lib_js_of_ocaml_eio/js_of_ocaml_eio.ml new file mode 100644 index 000000000..bc5b666bd --- /dev/null +++ b/lib_js_of_ocaml_eio/js_of_ocaml_eio.ml @@ -0,0 +1,12 @@ +module XmlHttpRequest = struct + include Js_of_ocaml.XmlHttpRequest + include XmlHttpRequest +end + +module File = struct + include Js_of_ocaml.File + include File +end + +module Eio_js = Eio_js +module Eio_js_events = Js_events diff --git a/lib_js_of_ocaml_eio/xmlHttpRequest.ml b/lib_js_of_ocaml_eio/xmlHttpRequest.ml new file mode 100644 index 000000000..79cca21e2 --- /dev/null +++ b/lib_js_of_ocaml_eio/xmlHttpRequest.ml @@ -0,0 +1,282 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2010 Jérôme Vouillon + * Laboratoire PPS - CNRS Université Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Js_of_ocaml +open Js +open XmlHttpRequest + +let encode_url l = + String.concat "&" + (List.map + (function + | name, `String s -> + Url.urlencode name ^ "=" ^ Url.urlencode (to_string s) + | name, `File s -> + Url.urlencode name ^ "=" ^ Url.urlencode (to_string s##.name)) + l) + +(* Higher level interface: *) + +type 'response generic_http_frame = { + url : string; + code : int; + headers : string -> string option; + content : 'response; + content_xml : unit -> Dom.element Dom.document t option; +} +(** type of the http headers *) + +type http_frame = string generic_http_frame + +exception Wrong_headers of (int * (string -> string option)) + +let default_response url code headers req = + { + url; + code; + content = + Js.Opt.case req##.responseText (fun () -> "") (fun x -> Js.to_string x); + content_xml = + (fun () -> + match Js.Opt.to_option req##.responseXML with + | None -> None + | Some doc -> + if Js.some doc##.documentElement == Js.null then None else Some doc); + headers; + } + +let text_response url code headers req = + { + url; + code; + content = + Js.Opt.case req##.responseText (fun () -> Js.string "") (fun x -> x); + content_xml = (fun () -> assert false); + headers; + } + +let document_response url code headers req = + { + url; + code; + content = File.CoerceTo.document req##.response; + content_xml = (fun () -> assert false); + headers; + } + +let json_response url code headers req = + { + url; + code; + content = File.CoerceTo.json req##.response; + content_xml = (fun () -> assert false); + headers; + } + +let blob_response url code headers req = + { + url; + code; + content = File.CoerceTo.blob req##.response; + content_xml = (fun () -> assert false); + headers; + } + +let arraybuffer_response url code headers req = + { + url; + code; + content = File.CoerceTo.arrayBuffer req##.response; + content_xml = (fun () -> assert false); + headers; + } + +let has_get_args url = + try + ignore (String.index url '?'); + true + with Not_found -> false + +let perform_raw ?(headers = []) ?content_type ?(get_args = []) + ?(check_headers = fun _ _ -> true) ?progress ?upload_progress ?contents + ?override_mime_type ?override_method ?with_credentials (type resptype) + ~(response_type : resptype response) url = + let contents_normalization = function + | `POST_form args -> + let only_strings = + List.for_all + (fun x -> match x with _, `String _ -> true | _ -> false) + args + in + let form_contents = + if only_strings then `Fields (ref []) else Form.empty_form_contents () + in + List.iter + (fun (name, value) -> Form.append form_contents (name, value)) + args; + `Form_contents form_contents + | (`String _ | `Form_contents _) as x -> x + | `Blob b -> `Blob (b : #File.blob Js.t :> File.blob Js.t) + in + let contents = + match contents with + | None -> None + | Some c -> Some (contents_normalization c) + in + let method_to_string m = + match m with + | `GET -> "GET" + | `POST -> "POST" + | `HEAD -> "HEAD" + | `PUT -> "PUT" + | `DELETE -> "DELETE" + | `OPTIONS -> "OPTIONS" + | `PATCH -> "PATCH" + in + let method_, content_type = + let override_method m = + match override_method with None -> m | Some v -> method_to_string v + in + let override_content_type c = + match content_type with None -> Some c | Some _ -> content_type + in + match contents with + | None -> (override_method "GET", content_type) + | Some (`Form_contents form) -> ( + match form with + | `Fields _strings -> + ( override_method "POST", + override_content_type "application/x-www-form-urlencoded" ) + | `FormData _ -> (override_method "POST", content_type)) + | Some (`String _ | `Blob _) -> (override_method "POST", content_type) + in + let url = + if get_args = [] then url + else + url + ^ (if has_get_args url then "&" else "?") + ^ Url.encode_arguments get_args + in + Eio_js_backend.await + ~setup:(fun ~resolve ~reject -> + let req = create () in + req##_open (Js.string method_) (Js.string url) Js._true; + (match override_mime_type with + | None -> () + | Some mime_type -> req##overrideMimeType (Js.string mime_type)); + (match response_type with + | ArrayBuffer -> req##.responseType := Js.string "arraybuffer" + | Blob -> req##.responseType := Js.string "blob" + | Document -> req##.responseType := Js.string "document" + | JSON -> req##.responseType := Js.string "json" + | Text -> req##.responseType := Js.string "text" + | Default -> req##.responseType := Js.string ""); + (match with_credentials with + | Some c -> req##.withCredentials := Js.bool c + | None -> ()); + (match content_type with + | Some content_type -> + req##setRequestHeader (Js.string "Content-type") + (Js.string content_type) + | _ -> ()); + List.iter + (fun (n, v) -> req##setRequestHeader (Js.string n) (Js.string v)) + headers; + let headers s = + Opt.case + (req##getResponseHeader (Js.bytestring s)) + (fun () -> None) + (fun v -> Some (Js.to_string v)) + in + let do_check_headers = + let st = ref `Not_yet in + fun () -> + if !st = `Not_yet then + if check_headers req##.status headers then st := `Passed + else ( + reject (Wrong_headers (req##.status, headers)); + st := `Failed; + req##abort); + !st <> `Failed + in + req##.onreadystatechange := + Js.wrap_callback (fun _ -> + match req##.readyState with + (* IE doesn't have the same semantics for HEADERS_RECEIVED. + so we wait til LOADING to check headers. See: + http://msdn.microsoft.com/en-us/library/ms534361(v=vs.85).aspx *) + | HEADERS_RECEIVED when not Dom_html.onIE -> + ignore (do_check_headers ()) + | LOADING when Dom_html.onIE -> ignore (do_check_headers ()) + | DONE -> + (* If we didn't catch a previous event, we check the header. *) + if do_check_headers () then + let response : resptype generic_http_frame = + match response_type with + | ArrayBuffer -> + arraybuffer_response url req##.status headers req + | Blob -> blob_response url req##.status headers req + | Document -> document_response url req##.status headers req + | JSON -> json_response url req##.status headers req + | Text -> text_response url req##.status headers req + | Default -> default_response url req##.status headers req + in + resolve response + | _ -> ()); + (match progress with + | Some progress -> + req##.onprogress := + Dom.handler (fun e -> + progress e##.loaded e##.total; + Js._true) + | None -> ()); + Optdef.iter req##.upload (fun upload -> + match upload_progress with + | Some upload_progress -> + upload##.onprogress := + Dom.handler (fun e -> + upload_progress e##.loaded e##.total; + Js._true) + | None -> ()); + (match contents with + | None -> req##send Js.null + | Some (`Form_contents (`Fields l)) -> + req##send (Js.some (string (encode_url !l))) + | Some (`Form_contents (`FormData f)) -> req##send_formData f + | Some (`String s) -> req##send (Js.some (Js.string s)) + | Some (`Blob b) -> req##send_blob b); + req) + ~cancel:(fun req -> req##abort) + +let perform_raw_url ?(headers = []) ?content_type ?(get_args = []) + ?check_headers ?progress ?upload_progress ?contents ?override_mime_type + ?override_method ?with_credentials url = + perform_raw ~headers ?content_type ~get_args ?contents ?check_headers + ?progress ?upload_progress ?override_mime_type ?override_method + ?with_credentials ~response_type:Default url + +let perform ?(headers = []) ?content_type ?(get_args = []) ?check_headers + ?progress ?upload_progress ?contents ?override_mime_type ?override_method + ?with_credentials url = + perform_raw ~headers ?content_type ~get_args ?contents ?check_headers + ?progress ?upload_progress ?override_mime_type ?override_method + ?with_credentials ~response_type:Default (Url.string_of_url url) + +let get s = perform_raw_url s diff --git a/lib_js_of_ocaml_eio/xmlHttpRequest.mli b/lib_js_of_ocaml_eio/xmlHttpRequest.mli new file mode 100644 index 000000000..c2d9dd952 --- /dev/null +++ b/lib_js_of_ocaml_eio/xmlHttpRequest.mli @@ -0,0 +1,120 @@ +(* Js_of_ocaml library + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2010 Jérôme Vouillon + * Laboratoire PPS - CNRS Université Paris Diderot + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +(** XmlHttpRequest object. *) + +open Js_of_ocaml +open Js +open XmlHttpRequest + +type 'response generic_http_frame = { + url : string; + code : int; + headers : string -> string option; + content : 'response; + content_xml : unit -> Dom.element Dom.document t option; +} +(** The type for XHR results. The code field is the http status code of the + answer. The headers field is a function associating values to any header + name. *) + +type http_frame = string generic_http_frame + +exception Wrong_headers of (int * (string -> string option)) +(** The exception raise by perform functions when the check_headers + parameter returned false. The parameter of the exception is a + function is like the [headers] function of [http_frame] *) + +val perform_raw : + ?headers:(string * string) list -> + ?content_type:string -> + ?get_args:(string * string) list -> + ?check_headers:((* [] *) + int -> (string -> string option) -> bool) -> + ?progress:(int -> int -> unit) -> + ?upload_progress:(int -> int -> unit) -> + ?contents: + [< `POST_form of (string * Form.form_elt) list + | `Form_contents of Form.form_contents + | `String of string + | `Blob of #File.blob Js.t ] -> + ?override_mime_type:string -> + ?override_method:[< `GET | `POST | `HEAD | `PUT | `DELETE | `OPTIONS | `PATCH ] -> + ?with_credentials:bool -> + response_type:'a response -> + string -> + 'a generic_http_frame +(** [perform_raw] is the same as {!perform_raw_url} except that an additional + response_type argument can be given to set the XMLHttpRequest + responseType, and hence return different types of data for GET + requests. *) + +val perform_raw_url : + ?headers:(string * string) list -> + ?content_type:string -> + ?get_args:(string * string) list -> + ?check_headers:((* [] *) + int -> (string -> string option) -> bool) -> + ?progress:(int -> int -> unit) -> + ?upload_progress:(int -> int -> unit) -> + ?contents: + [< `POST_form of (string * Form.form_elt) list + | `Form_contents of Form.form_contents + | `String of string + | `Blob of #File.blob Js.t ] -> + ?override_mime_type:string -> + ?override_method:[< `GET | `POST | `HEAD | `PUT | `DELETE | `OPTIONS | `PATCH ] -> + ?with_credentials:bool -> + string -> + http_frame +(** [perform_raw_url] makes an asynchronous request to the specified [url] with + specified options. The result is a cancelable thread returning + an HTTP frame. By default, if [post_args] and [form_arg] are [None], a GET + request is used. If [post_args] or [form_arg] is [Some _] (even [Some []]) then a POST + request is made. But if [override_method] is set, the request method is forced, + no matter the [post_args] or [form_arg] value. For example, with [override_method] + set to [`PUT] and [form_arg] set to [Some _] a PUT request including the form data + will be made. The [check_headers] argument is run as soon as the answer + code and headers are available. If it returns false, the request is canceled + and the functions raise the [Wrong_headers] exception *) + +val perform : + ?headers:(string * string) list -> + ?content_type:string -> + ?get_args:(string * string) list -> + ?check_headers:((* [] *) + int -> (string -> string option) -> bool) -> + ?progress:(int -> int -> unit) -> + ?upload_progress:(int -> int -> unit) -> + ?contents: + [< `POST_form of (string * Form.form_elt) list + | `Form_contents of Form.form_contents + | `String of string + | `Blob of #File.blob Js.t ] -> + ?override_mime_type:string -> + ?override_method:[< `GET | `POST | `HEAD | `PUT | `DELETE | `OPTIONS | `PATCH ] -> + ?with_credentials:bool -> + Url.url -> + http_frame +(** [perform] is the same as {!perform_raw_url} except that the Url argument has type + [Url.url]. *) + +val get : string -> http_frame +(** [get url] makes an asynchronous request to the specified [url] *)