11 | Direct of string * (unit -> string)
14 let children_of_node node =
16 for i = 0 to node##childNodes##length - 1 do
17 let node = Js.Opt.get (node##childNodes##item (i)) (fun _ -> assert false) in
18 match node##nodeType with
19 | Dom.DOCUMENT | Dom.DOCUMENT_FRAGMENT | Dom.ELEMENT | Dom.CDATA_SECTION ->
25 let contents_of_node (node : node Js.t) =
27 match node##nodeType with
28 | Dom.CDATA_SECTION ->
29 let t = Js.Opt.get (Dom.CoerceTo.text (node :> node Js.t)) (fun _ -> assert false) in
32 for i = 0 to node##childNodes##length - 1 do
33 let node = Js.Opt.get (node##childNodes##item (i)) (fun _ -> assert false) in
34 match node##nodeType with
35 | Dom.TEXT | Dom.CDATA_SECTION ->
39 Js.Opt.get ((List.hd !c)##nodeValue) (fun _ -> Js.string "Error")
44 XmlHttpRequest.get url >>= fun r ->
45 let cod = r.XmlHttpRequest.code in
46 let msg = r.XmlHttpRequest.content_xml () in
47 if cod = 0 || cod = 200
49 else fst (Lwt.wait ())
51 let load_input_from_url url =
52 let extract_inputs frame =
55 Dom_html.window##alert (Js.string "Loading of examples failed.");
58 let inputs_root = List.hd (children_of_node inputs_doc) in
59 let inputs_nodes = children_of_node inputs_root in
60 let inputs = List.map (fun n ->
62 let data = children_of_node n in
64 let get i = Js.to_string (contents_of_node (List.nth data i)) in
65 (get 0, fun () -> get 1))
70 Lwt.catch (fun () -> http_get url
72 Lwt.return (extract_inputs frame)))
77 type output = (string * string)
79 let impossible _ = assert false
81 let ccs s = Goog.Ui.ControlContent.string (Js.string s)
83 let add_item s (m : Goog.Ui.menu Js.t) =
84 m##addItem (Goog.Tools.Union.i1 jsnew Goog.Ui.menuItem (ccs s, Js.null, Js.null))
88 (Dom_html.document##getElementById (s))
89 (fun _ -> Dom_html.window##alert (s); assert false)
91 let new_tab tabbar label =
92 let tab = jsnew Ui.tab (Ui.ControlContent.string label, Js.null, Js.null) in
93 Ui.Component.addChild tabbar tab (Js.some Js._true);
96 let new_button toolbar label onclick =
98 jsnew Ui.toolbarButton
99 (Ui.ControlContent.string (Js.string label),
103 Ui.Component.addChild toolbar button (Js.some Js._true);
106 (Tools.Union.i1 button)
108 (Js.wrap_callback (fun _ -> onclick ()))
111 let new_menu toolbar label entries onchange =
112 let menu = jsnew Goog.Ui.menu (Js.null, Js.null) in
113 List.iter (fun s -> add_item s menu) entries;
115 jsnew Ui.toolbarMenuButton
116 (Ui.ControlContent.string (Js.string label),
123 (Tools.Union.i1 menu_button)
125 (Js.wrap_callback (fun e ->
126 let get x : Goog.Ui.menuItem Js.t =
127 Js.Unsafe.coerce (Js.Optdef.get x (fun _ -> assert false))
129 onchange ((get (e##target))##getCaption ())))
132 Ui.Component.addChild toolbar menu_button (Js.some Js._true);
135 type input_interface = {
136 get_input : unit -> Js.js_string Js.t * Js.js_string Js.t;
137 new_output_tabs : (Js.js_string Js.t * Js.js_string Js.t) list -> unit;
138 clear_output_tabs : unit -> unit;
142 let input_interfaces : (Js.js_string Js.t, input_interface) Hashtbl.t =
147 let name = if i = 0 then n else (n##concat (Js.string (string_of_int i))) in
148 if Hashtbl.mem input_interfaces name then
155 let new_input (tabbar : Ui.tabBar Js.t) choice (contents : Js.js_string Js.t) =
157 let choice = fresh_name choice in
159 let tab_contents = get_element ((Js.string "maintabbar_content")) in
161 let source_label = choice##concat (Js.string "_source") in
162 let content_label = choice##concat (Js.string "_contents") in
164 let tab = new_tab tabbar choice in
165 let tab_frame = Dom_html.createDiv (Dom_html.document) in
166 let subtab_frame = Dom_html.createDiv (Dom_html.document) in
167 let contents_tab_frame = Dom_html.createDiv (Dom_html.document) in
168 let clear_tab_frame = Dom_html.createDiv (Dom_html.document) in
171 Js.some (Ui.TabBar.location_pre_of_location Ui.TabBar.BOTTOM),
175 contents_tab_frame##className <- Js.string "goog-tab-content";
176 contents_tab_frame##id <- content_label;
177 subtab_frame##className
178 <- Js.string "goog-tab-bar goog-tab-bar-start";
179 clear_tab_frame##className <- Js.string "goog-tab-bar-clear";
181 subtabs##decorate ((subtab_frame :> Dom_html.element Js.t));
182 ignore (tab_frame##appendChild ((subtab_frame :> Dom.node Js.t)));
183 ignore (tab_frame##appendChild ((contents_tab_frame :> Dom.node Js.t)));
184 ignore (tab_frame##appendChild ((clear_tab_frame :> Dom.node Js.t)));
186 (* Source code editor. *)
187 let text = Dom_html.createTextarea (Dom_html.document) in
188 text##className <- Js.string "editor";
189 text##value <- contents;
191 let change_tab_content node =
192 if contents_tab_frame##hasChildNodes () = _true then
193 ignore (contents_tab_frame##removeChild
194 (Js.Opt.get contents_tab_frame##firstChild impossible));
195 ignore (contents_tab_frame##appendChild (node))
198 let input_tab = new_tab subtabs source_label in
201 (Tools.Union.i1 input_tab)
203 (Js.wrap_callback (fun e -> change_tab_content ((text :> Dom.node Js.t))))
210 (Js.wrap_callback (fun e ->
211 if tab_contents##hasChildNodes () = _true then
212 ignore (tab_contents##removeChild
213 (Js.Opt.get tab_contents##firstChild impossible));
214 ignore (tab_contents##appendChild ((tab_frame :> Dom.node Js.t)))))
217 tabbar##setSelectedTab (Js.some tab);
218 subtabs##setSelectedTab (Js.some input_tab);
221 (choice, text##value)
224 let output_tabs = ref [] in
226 let new_output_tabs outputs =
227 let new_output_tab (title, value) =
228 let output_tab = new_tab subtabs (choice##concat (title)) in
229 let output_frame = Dom_html.createDiv (Dom_html.document) in
230 output_tabs := output_tab :: !output_tabs;
231 let text = Dom_html.createTextarea (Dom_html.document) in
232 text##className <- Js.string "editor";
233 text##value <- value;
234 ignore (output_frame##appendChild ((text :> Dom.node Js.t)));
237 (Tools.Union.i1 output_tab)
239 (Js.wrap_callback (fun e ->
240 change_tab_content ((output_frame :> Dom.node Js.t))))
243 List.iter new_output_tab outputs
246 let clear_output_tabs () =
247 List.iter (fun tab ->
248 ignore (subtabs##removeChild (Goog.Tools.Union.i2 tab, Js.some Js._true)))
254 Hashtbl.remove input_interfaces choice;
255 ignore (contents_tab_frame##removeChild ((text :> Dom.node Js.t)));
256 subtabs##disposeInternal ();
257 ignore (tabbar##removeChild (Goog.Tools.Union.i2 tab, Js.some Js._true))
259 Hashtbl.add input_interfaces choice
261 get_input = get_input;
262 new_output_tabs = new_output_tabs;
263 clear_output_tabs = clear_output_tabs;
270 Please be aware of the limited computational power of JavaScript. Your O'Caml
271 program will run 10 times slower than a natively compiled one.
275 Use <code>Create from...</code> to load
276 a predefined input. This should create a tab in the
277 interface for this specific instance of the input. You
278 can freely edit this input in the text area.
281 Use <code>Run</code> to process the input. This should create
282 a set of tabs to store the outputs. You can use
283 <code>Run</code> several times: the outputs will be refreshed
284 if the input has changed.
287 Use <code>Close</code> to dispose the input instance corresponding
288 to the selected tab. Be aware that you will lost your local modifications.
291 Use <code>Help</code> to open this dialog box.
296 type processor_function =
297 (int -> int -> unit) -> (** Tick *)
301 let processing_queue_updated = Lwt_condition.create ()
302 let q = Queue.create ()
303 let push_processing f =
304 Queue.push f q; Lwt_condition.signal processing_queue_updated ()
305 let next_processing () = (Queue.take q) ()
307 let make_layout, add_inputs, register_processor =
308 let menu_ref = ref (Obj.magic 0) in
309 let inputs_ref : (Js.js_string Js.t * (unit -> Js.js_string Js.t)) list ref = ref [] in
310 let processor_ref : processor_function ref =
311 ref (fun tick s -> [])
314 let pbar = jsnew Ui.progressBar () in
315 let elt = get_element (Js.string "progressbar") in
316 let elt_txt = get_element (Js.string "progressbarin") in
317 pbar##setMaximum (100.);
318 pbar##setMinimum (0.);
320 pbar##decorateInternal (elt);
322 let toolbar = jsnew Ui.toolbar (Js.null, Js.null, Js.null) in
324 jsnew Ui.tabBar (Js.some (Ui.TabBar.location_pre_of_location Ui.TabBar.START), Js.null, Js.null)
327 let get_selected_input () =
329 let tab = (Js.Opt.get (tabbar##getSelectedTab ()) impossible) in
330 let caption = (Js.Opt.get (tab##getCaption ()) impossible) in
335 new_menu toolbar " Create from ..." []
338 let choice = Js.Opt.get choice (fun _ -> assert false) in
339 let contents = (List.assoc choice !inputs_ref) () in
340 new_input tabbar choice contents
341 with _ -> assert false);
343 new_button toolbar "Run" (fun () ->
344 match get_selected_input () with
346 Firebug.console##log (Js.string "Nothing to run!")
348 | Some selected_input ->
350 Firebug.console##log ((Js.string "Process the source named ")##concat (selected_input));
354 Hashtbl.find input_interfaces selected_input
355 with Not_found -> assert false
357 interface.clear_output_tabs ();
360 let v = 100. *. float_of_int step /. float_of_int over in
361 Firebug.console##log ((Js.string ("Step " ^ string_of_int step ^ " " ^ string_of_float v)));
363 elt_txt##innerHTML <- Js.string (string_of_float v ^ "%")
367 let title, contents = interface.get_input () in
368 !processor_ref tick (Js.to_string title, Js.to_string contents)
370 [("Error", Printexc.to_string exn)]
372 interface.new_output_tabs
373 (List.map (fun (t, o) -> (Js.string t, Js.string o)) outputs);
379 new_button toolbar "Close" (fun () ->
380 match get_selected_input () with
382 Firebug.console##log (Js.string "Nothing to close!")
383 | Some selected_input ->
384 Firebug.console##log ((Js.string "Closing ")##concat (selected_input));
387 Hashtbl.find input_interfaces selected_input
388 with Not_found -> assert false
393 new_button toolbar "Help" (fun () ->
394 let dialog = jsnew Ui.dialog (Js.null, Js.null, Js.null) in
395 dialog##setContent (Js.string help_message);
396 dialog##setVisible (Js._true)
399 tabbar##decorate (get_element (Js.string "maintabbar"));
400 toolbar##render (Js.some (get_element (Js.string "maintoolbar")))
402 let add_inputs inputs =
403 List.iter (fun (s, _) -> add_item s !menu_ref) inputs;
404 inputs_ref := List.map (fun (k, v) -> (Js.string k, fun () -> Js.string (v ()))) inputs
406 let register_processor p =
409 make_layout, add_inputs, register_processor
411 let loaded = ref Js._false
413 let rec load = function
416 | Direct (title, contents) :: is ->
418 >>= (fun is -> Lwt.return ((title, contents) :: is))
420 load_input_from_url url
423 >>= (fun is -> Lwt.return (url_is @ is)))
425 let from_function inputs processor =
427 let rec wait_for_processing () =
428 Lwt_condition.wait processing_queue_updated
430 >>= wait_for_processing
433 >>= (fun () -> load inputs)
434 >>= fun inputs -> begin
437 register_processor processor;
438 Firebug.console##log (Js.string "Loaded!");
441 >>= wait_for_processing
443 Dom_html.window##onload <- Dom_html.handler (fun _ -> ignore (start ()); Js._false)