diff options
Diffstat (limited to 'viz.js')
| -rwxr-xr-x | viz.js/convert.ml | 233 | ||||
| -rwxr-xr-x | viz.js/dune | 48 | ||||
| -rwxr-xr-x | viz.js/process/process.ml | 40 | ||||
| -rwxr-xr-x | viz.js/promise/promise.ml | 42 |
4 files changed, 181 insertions, 182 deletions
diff --git a/viz.js/convert.ml b/viz.js/convert.ml index 68bf244..a615ce4 100755 --- a/viz.js/convert.ml +++ b/viz.js/convert.ml @@ -2,153 +2,168 @@ open Js_of_ocaml open Js_of_ocaml_lwt (** Event generated once the library has created the svg image *) -let (generated_svg_event:(Dom_svg.svgElement Js.t * Js.js_string Js.t) Dom.Event.typ) - = Dom_html.Event.make "generated_svg" - -(* Save the generated image *) -let on_result_png image = begin - let a = Dom_html.createA Dom_html.document in - a##.href := image##.src; - Js.Unsafe.set a (Js.string "download") (Js.string "output.png"); - Dom.appendChild Dom_html.document##.body a; - a##click; - Dom.removeChild Dom_html.document##.body a -end - -let on_result_svg - : Dom_html.element Js.t -> (Dom.node Js.t) -> unit - = fun svg_display image -> begin - let childNodes = svg_display##.childNodes in - for i = 0 to childNodes##.length do - Js.Opt.iter (childNodes##item i) (fun elem -> ignore @@ svg_display##removeChild elem) - done; - Dom.appendChild svg_display image; - () - end +let (generated_svg_event : + (Dom_svg.svgElement Js.t * Js.js_string Js.t) Dom.Event.typ) = + Dom_html.Event.make "generated_svg" + +(** Save the generated image *) +let on_result_png image = + begin + let a = Dom_html.createA Dom_html.document in + a##.href := image##.src; + Js.Unsafe.set a (Js.string "download") (Js.string "output.png"); + Dom.appendChild Dom_html.document##.body a; + a##click; + Dom.removeChild Dom_html.document##.body a + end + +let on_result_svg : Dom_html.element Js.t -> Dom.node Js.t -> unit = + fun svg_display image -> + begin + let childNodes = svg_display##.childNodes in + for i = 0 to childNodes##.length do + Js.Opt.iter + (childNodes##item i) + (fun elem -> ignore @@ svg_display##removeChild elem) + done; + Dom.appendChild svg_display image; + () + end -(** Message send by the worker *) type message = Process.t +(** Message send by the worker *) + type worker = (Js.js_string Js.t, message) Worker.worker Js.t -let change_event (worker:worker) input _ev _ = begin - let text: Js.js_string Js.t = input##.value in +let change_event (worker : worker) input _ev _ = + begin + let text : Js.js_string Js.t = input##.value in - (* Send the content to the worker *) - let () = worker##postMessage text in - Lwt.return_unit -end + (* Send the content to the worker *) + let () = worker##postMessage text in + Lwt.return_unit + end class type _Dom_parser = object - method parseFromString: Js.js_string Js.t -> Js.js_string Js.t -> Dom_html.document Js.t Js.meth + method parseFromString : + Js.js_string Js.t -> Js.js_string Js.t -> Dom_html.document Js.t Js.meth end -let dom_parser = (Js.Unsafe.global##._DOMParser) +let dom_parser = Js.Unsafe.global##._DOMParser let dom_parser = new%js dom_parser let load () = - (* The URL is be relative with the page location. If the worker is called from diffenent location, it becomes mandatory to declare the URL as absolute. *) - let (worker:worker) = Worker.create "/resources/viz.js/worker.js" in + let (worker : worker) = Worker.create "/resources/viz.js/worker.js" in - worker##.onmessage := Dom.handler (fun (event: message Worker.messageEvent Js.t) -> - let gv, image = event##.data in - let image = dom_parser##parseFromString image "image/svg+xml" in - let image = image##.documentElement in + let handler : (_, (_, _) Dom_html.messageEvent Js.t) Dom_html.event_listener = + Dom.handler (fun (event : (_, message) Dom_html.messageEvent Js.t) -> + let gv, image = event##.data in + let image = dom_parser##parseFromString image "image/svg+xml" in + let image = image##.documentElement in - let _ = Dispatch.call generated_svg_event (image, gv) in - Js._true); + let _ = Dispatch.call generated_svg_event (image, gv) in + Js._true) + in + worker##.onmessage := handler; let svg_display = Dom_html.getElementById_exn "svg" and output_button = Dom_html.getElementById_exn "png_output" and dot_button = Dom_html.getElementById_exn "dot_output" and editor = Dom_html.getElementById_exn "editor" in - ignore @@ Dispatch.register generated_svg_event (fun (image, input) -> - + ignore + @@ Dispatch.register generated_svg_event (fun (image, input) -> on_result_svg svg_display (image :> Dom.node Js.t); (* Download the dot file *) - dot_button##.onclick := Dom_html.handler (fun _ev -> - let _ = Elements.Transfert.send - ~mime_type:(Jstr.v "text/plain") - ~filename:(Jstr.v "output.dot") - (Obj.magic input) in - Js._false - ); + dot_button##.onclick := + Dom_html.handler (fun _ev -> + let _ = + Elements.Transfert.send ~mime_type:(Jstr.v "text/plain") + ~filename:(Jstr.v "output.dot") (Obj.magic input) + in + Js._false); (* Convert the svg in png *) - output_button##.onclick := Dom_html.handler (fun _-> - (*download image*) - CanvasTool.generate_png image (fun image -> - let _ = - Elements.Transfert.send_raw - ~filename:(Jstr.v "output.png") - (Obj.magic image) in - () - ); - Js._false - ); - ); + output_button##.onclick := + Dom_html.handler (fun _ -> + (*download image*) + CanvasTool.generate_png image (fun image -> + let _ = + Elements.Transfert.send_raw ~filename:(Jstr.v "output.png") + (Obj.magic image) + in + ()); + Js._false)); Js.Opt.iter (Dom_html.CoerceTo.textarea editor) (fun input -> - Lwt_js_events.async (fun () -> (Lwt_js_events.limited_loop Lwt_js_events.change ~elapsed_time:0.1 editor (change_event worker input) )); - Lwt_js_events.async (fun () -> (Lwt_js_events.limited_loop Lwt_js_events.input ~elapsed_time:0.1 editor (change_event worker input) )); + Lwt_js_events.async (fun () -> + Lwt_js_events.limited_loop Lwt_js_events.change ~elapsed_time:0.1 + editor + (change_event worker input)); + Lwt_js_events.async (fun () -> + Lwt_js_events.limited_loop Lwt_js_events.input ~elapsed_time:0.1 + editor + (change_event worker input)); (* Run the first generation *) - Lwt.ignore_result (change_event worker input () ()); - ); + Lwt.ignore_result (change_event worker input () ())); - (** Handle the separation window *) + (* Handle the separation window *) Option.iter (fun button -> - let _ = Dom_events.listen button Dom_html.Event.click (fun _ _ -> - - let opt_window2 = Dom_html.window##open_ - (Js.string "") - (Js.string "_image") - Js.Opt.empty in - - Js.Opt.iter opt_window2 (fun window2 -> - - let callback - : Dom_svg.svgElement Js.t * Js.js_string Js.t -> unit - = fun (image, _gv) -> begin - let node2 = image##cloneNode Js._true in - let () = on_result_svg window2##.document##.body - (node2 :> Dom.node Js.t) in - () - end in - let handler = Dispatch.register generated_svg_event callback in - - (* Remove the update event when the window is closed *) - window2##.onunload := Dom_html.handler (fun _ev -> - Dispatch.remove generated_svg_event handler; - Js._false - ); - - (* Copy the current display to the new window *) - let childNodes = svg_display##.childNodes in - for i = 0 to childNodes##.length do - Js.Opt.iter - (childNodes##item i) - (fun elem -> - Dom.appendChild window2##.document##.body (elem##cloneNode Js._true) - ) - done; - ); - - false - ) in - () - ) + let _ = + Dom_events.listen button Dom_html.Event.click (fun _ _ -> + let opt_window2 = + Dom_html.window##open_ (Js.string "") (Js.string "_image") + Js.Opt.empty + in + + Js.Opt.iter opt_window2 (fun window2 -> + let callback : + Dom_svg.svgElement Js.t * Js.js_string Js.t -> unit = + fun (image, _gv) -> + begin + let node2 = image##cloneNode Js._true in + let () = + on_result_svg + window2##.document##.body + (node2 :> Dom.node Js.t) + in + () + end + in + let handler = Dispatch.register generated_svg_event callback in + + (* Remove the update event when the window is closed *) + window2##.onunload := + Dom_html.handler (fun _ev -> + Dispatch.remove generated_svg_event handler; + Js._false); + + (* Copy the current display to the new window *) + let childNodes = svg_display##.childNodes in + for i = 0 to childNodes##.length do + Js.Opt.iter + (childNodes##item i) + (fun elem -> + Dom.appendChild + window2##.document##.body + (elem##cloneNode Js._true)) + done); + + false) + in + ()) (Dom_html.getElementById_opt "btn_window"); Lwt.return Js._false -let _ = Lwt.bind (Lwt_js_events.onload ()) (fun _ -> load()) +let _ = Lwt.bind (Lwt_js_events.onload ()) (fun _ -> load ()) let _ = Js.export "generator" - (object%js + object%js method load = load () - end) + end diff --git a/viz.js/dune b/viz.js/dune index 18ba438..9b421b6 100755 --- a/viz.js/dune +++ b/viz.js/dune @@ -1,39 +1,31 @@ (executable (name convert) - (libraries - js_of_ocaml - js_of_ocaml-lwt - promise - process - elements - brr - ) + (libraries js_of_ocaml js_of_ocaml-lwt promise process elements brr) (modes js) - (preprocess (pps js_of_ocaml-ppx)) - (link_flags (:standard -no-check-prims)) - (modules convert dispatch CanvasTool) - ) + (preprocess + (pps js_of_ocaml-ppx)) + (link_flags + (:standard -no-check-prims)) + (modules convert dispatch CanvasTool)) (rule - (targets convert.js) - (deps convert.bc.js) - (action (copy %{deps} %{targets}))) + (targets convert.js) + (deps convert.bc.js) + (action + (copy %{deps} %{targets}))) (executable (name worker) - (libraries - js_of_ocaml - js_of_ocaml-lwt - promise - process - ) + (libraries js_of_ocaml js_of_ocaml-lwt promise process) (modes js) - (preprocess (pps js_of_ocaml-ppx)) - (link_flags (:standard -no-check-prims)) - (modules worker) - ) + (preprocess + (pps js_of_ocaml-ppx)) + (link_flags + (:standard -no-check-prims)) + (modules worker)) (rule - (targets worker.js) - (deps worker.bc.js) - (action (copy %{deps} %{targets}))) + (targets worker.js) + (deps worker.bc.js) + (action + (copy %{deps} %{targets}))) diff --git a/viz.js/process/process.ml b/viz.js/process/process.ml index ef23b78..8d37788 100755 --- a/viz.js/process/process.ml +++ b/viz.js/process/process.ml @@ -1,29 +1,27 @@ -open Js_of_ocaml +module Js = Js_of_ocaml.Js class type viz = object - (* PNG output *) - method renderImageElement: Js.js_string Js.t -> (Dom_html.imageElement Js.t, unit) Promise.promise Js.meth (* SVG output *) - method renderSVGElement: Js.js_string Js.t -> (Dom_svg.svgElement Js.t, unit) Promise.promise Js.meth + method renderSVGElement : + Js.js_string Js.t + -> (Js_of_ocaml.Dom_svg.svgElement Js.t, unit) Promise.promise Js.meth - method renderString: Js.js_string Js.t -> (Js.js_string Js.t, unit) Promise.promise Js.meth + method renderString : + Js.js_string Js.t -> (Js.js_string Js.t, unit) Promise.promise Js.meth end type t = Js.js_string Js.t * Js.js_string Js.t -let do_action - : viz Js.t -> Js.js_string Js.t -> (unit, unit) Promise.promise - = fun v text -> - - if text##.length != 0 then ( - let gv = Formatter.convert text in - let promise = - (try v##renderString gv - with _ -> Promise.reject () - ) in - Promise.then_map - ~on_fulfilled:(fun svg -> Worker.post_message ((gv, svg):t)) - ~on_rejected:(fun _ -> ()) - promise - ) else - Promise.reject () +let do_action : viz Js.t -> Js.js_string Js.t -> (unit, unit) Promise.promise = + fun v text -> + if text##.length != 0 then + let gv = Formatter.convert text in + let promise = + try v##renderString gv with + | _ -> Promise.reject () + in + Promise.then_map + ~on_fulfilled:(fun svg -> Js_of_ocaml.Worker.post_message ((gv, svg) : t)) + ~on_rejected:(fun _ -> ()) + promise + else Promise.reject () diff --git a/viz.js/promise/promise.ml b/viz.js/promise/promise.ml index f9f7e53..47acd28 100755 --- a/viz.js/promise/promise.ml +++ b/viz.js/promise/promise.ml @@ -1,66 +1,60 @@ open Js_of_ocaml type ('a, 'b) promise - type 'a resolve = 'a -> unit - type 'a reject = 'a -> unit let promise_global = Js.Unsafe.global##._Promise - let is_supported () = Js.Optdef.test promise_global - -let make f = - Js.Unsafe.new_obj promise_global [|Js.Unsafe.inject f|] +let make f = Js.Unsafe.new_obj promise_global [| Js.Unsafe.inject f |] let resolve value = - Js.Unsafe.fun_call promise_global##.resolve [|Js.Unsafe.inject value|] + Js.Unsafe.fun_call promise_global##.resolve [| Js.Unsafe.inject value |] let reject value = - Js.Unsafe.fun_call promise_global##.reject [|Js.Unsafe.inject value|] + Js.Unsafe.fun_call promise_global##.reject [| Js.Unsafe.inject value |] let js_of_opt = function | Some value -> Js.Unsafe.inject value - | None -> Js.Unsafe.inject Js.undefined + | None -> Js.Unsafe.inject Js.undefined let then_bind ~on_fulfilled ?on_rejected promise = Js.Unsafe.meth_call promise "then" - [|Js.Unsafe.inject on_fulfilled; js_of_opt on_rejected|] + [| Js.Unsafe.inject on_fulfilled; js_of_opt on_rejected |] let then_map ~on_fulfilled ?on_rejected promise = Js.Unsafe.meth_call promise "then" - [|Js.Unsafe.inject on_fulfilled; js_of_opt on_rejected|] + [| Js.Unsafe.inject on_fulfilled; js_of_opt on_rejected |] let catch_bind ~on_rejected promise = - Js.Unsafe.meth_call promise "catch" [|Js.Unsafe.inject on_rejected|] + Js.Unsafe.meth_call promise "catch" [| Js.Unsafe.inject on_rejected |] let catch_map ~on_rejected promise = - Js.Unsafe.meth_call promise "catch" [|Js.Unsafe.inject on_rejected|] + Js.Unsafe.meth_call promise "catch" [| Js.Unsafe.inject on_rejected |] let then_final ~on_fulfilled ~on_rejected promise = Js.Unsafe.meth_call promise "then" - [|Js.Unsafe.inject on_fulfilled; Js.Unsafe.inject on_rejected|] + [| Js.Unsafe.inject on_fulfilled; Js.Unsafe.inject on_rejected |] let all promises = let intermediate_promise = Js.Unsafe.fun_call promise_global##.all - [|Js.Unsafe.inject (Js.array promises)|] + [| Js.Unsafe.inject (Js.array promises) |] in then_map - ~on_fulfilled:(fun js_array -> Js.to_array js_array) intermediate_promise + ~on_fulfilled:(fun js_array -> Js.to_array js_array) + intermediate_promise let race promises = Js.Unsafe.fun_call promise_global##.race - [|Js.Unsafe.inject (Js.array promises)|] + [| Js.Unsafe.inject (Js.array promises) |] module Infix = struct - let (>>=) promise on_fulfilled = then_bind ~on_fulfilled promise - let (>|=) promise on_fulfilled = then_map ~on_fulfilled promise - - let (>>~) promise on_rejected = catch_bind ~on_rejected promise - let (>|~) promise on_rejected = catch_map ~on_rejected promise + let ( >>= ) promise on_fulfilled = then_bind ~on_fulfilled promise + let ( >|= ) promise on_fulfilled = then_map ~on_fulfilled promise + let ( >>~ ) promise on_rejected = catch_bind ~on_rejected promise + let ( >|~ ) promise on_rejected = catch_map ~on_rejected promise - let (>||) promise (on_fulfilled, on_rejected) = + let ( >|| ) promise (on_fulfilled, on_rejected) = then_final ~on_fulfilled ~on_rejected promise end - |