src/utilities/webify.ml

   1 open Dom
   2 open Dom_html
   3 open Js
   4 open Firebug
   5 open Goog
   6
   7 let msgbox s =
   8   console##log (s)
   9
  10 type input =
  11   | Direct of string * (unit -> string)
  12   | Url of string
  13
  14 let children_of_node node =
  15   let c = ref [] in
  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 ->
  20         c := node :: !c
  21       | _ -> ()
  22   done;
  23   List.rev !c
  24
  25 let contents_of_node (node : node Js.t) =
  26   let c = ref [] in
  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
  30       t##data
  31     | _ ->
  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 ->
  36             c := node :: !c
  37           | _ -> ()
  38       done;
  39       Js.Opt.get ((List.hd !c)##nodeValue) (fun _ -> Js.string "Error")
  40
  41 let (>>=) = Lwt.bind
  42
  43 let http_get url =
  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
  48   then Lwt.return msg
  49   else fst (Lwt.wait ())
  50
  51 let load_input_from_url url =
  52   let extract_inputs frame =
  53     match frame with
  54       | None ->
  55         Dom_html.window##alert (Js.string "Loading of examples failed.");
  56         []
  57       | Some inputs_doc ->
  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 ->
  61           msgbox n;
  62           let data = children_of_node n in
  63           msgbox data;
  64           let get i = Js.to_string (contents_of_node (List.nth data i)) in
  65           (get 0, fun () -> get 1))
  66           inputs_nodes
  67         in
  68         inputs
  69   in
  70   Lwt.catch (fun () -> http_get url
  71                        >>= (fun frame ->
  72                          Lwt.return (extract_inputs frame)))
  73     (function _ ->
  74       Lwt.return []
  75     )
  76
  77 type output = (string * string)
  78
  79 let impossible _ = assert false
  80
  81 let ccs s = Goog.Ui.ControlContent.string (Js.string s)
  82
  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))
  85
  86 let get_element s =
  87   Js.Opt.get
  88     (Dom_html.document##getElementById (s))
  89     (fun _ -> Dom_html.window##alert (s); assert false)
  90
  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);
  94   tab
  95
  96 let new_button toolbar label onclick =
  97   let button =
  98     jsnew Ui.toolbarButton
  99       (Ui.ControlContent.string (Js.string label),
 100        Js.null,
 101        Js.null)
 102   in
 103   Ui.Component.addChild toolbar button (Js.some Js._true);
 104   ignore
 105     (Events.listen
 106        (Tools.Union.i1 button)
 107        (Js.string "action")
 108        (Js.wrap_callback (fun _ -> onclick ()))
 109        Js.null)
 110
 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;
 114   let menu_button =
 115     jsnew Ui.toolbarMenuButton
 116       (Ui.ControlContent.string (Js.string label),
 117        Js.some menu,
 118        Js.null,
 119        Js.null)
 120   in
 121   ignore
 122     (Events.listen
 123        (Tools.Union.i1 menu_button)
 124        (Js.string "action")
 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))
 128          in
 129          onchange ((get (e##target))##getCaption ())))
 130        Js.null);
 131
 132   Ui.Component.addChild toolbar menu_button (Js.some Js._true);
 133   menu
 134
 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;
 139   close : unit -> unit
 140 }
 141
 142 let input_interfaces : (Js.js_string Js.t, input_interface) Hashtbl.t =
 143   Hashtbl.create 13
 144
 145 let fresh_name n =
 146   let rec aux i =
 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
 149       aux (i + 1)
 150     else
 151       name
 152   in
 153   aux 0
 154
 155 let new_input (tabbar : Ui.tabBar Js.t) choice (contents : Js.js_string Js.t) =
 156
 157   let choice = fresh_name choice in
 158
 159   let tab_contents = get_element ((Js.string "maintabbar_content")) in
 160
 161   let source_label = choice##concat (Js.string "_source") in
 162   let content_label = choice##concat (Js.string "_contents") in
 163
 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
 169   let subtabs =
 170     jsnew Ui.tabBar (
 171       Js.some (Ui.TabBar.location_pre_of_location Ui.TabBar.BOTTOM),
 172       Js.null,
 173       Js.null)
 174   in
 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";
 180
 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)));
 185
 186   (* Source code editor. *)
 187   let text = Dom_html.createTextarea (Dom_html.document) in
 188   text##className <- Js.string "editor";
 189   text##value <- contents;
 190
 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))
 196   in
 197
 198   let input_tab = new_tab subtabs source_label in
 199   ignore
 200     (Events.listen
 201        (Tools.Union.i1 input_tab)
 202        (Js.string "select")
 203        (Js.wrap_callback (fun e -> change_tab_content ((text :> Dom.node Js.t))))
 204        Js.null);
 205
 206   ignore
 207     (Events.listen
 208        (Tools.Union.i1 tab)
 209        (Js.string "select")
 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)))))
 215        Js.null);
 216
 217   tabbar##setSelectedTab   (Js.some tab);
 218   subtabs##setSelectedTab (Js.some input_tab);
 219
 220   let get_input () =
 221     (choice, text##value)
 222   in
 223
 224   let output_tabs = ref [] in
 225
 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)));
 235       ignore
 236         (Events.listen
 237            (Tools.Union.i1 output_tab)
 238            (Js.string "select")
 239            (Js.wrap_callback (fun e ->
 240              change_tab_content ((output_frame :> Dom.node Js.t))))
 241            Js.null)
 242     in
 243     List.iter new_output_tab outputs
 244   in
 245
 246   let clear_output_tabs () =
 247     List.iter (fun tab ->
 248       ignore (subtabs##removeChild (Goog.Tools.Union.i2 tab, Js.some Js._true)))
 249       !output_tabs;
 250     output_tabs := []
 251   in
 252
 253   let close () =
 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))
 258   in
 259   Hashtbl.add input_interfaces choice
 260   {
 261     get_input               = get_input;
 262     new_output_tabs   = new_output_tabs;
 263     clear_output_tabs = clear_output_tabs;
 264     close                         = close;
 265   }
 266
 267 let help_message =
 268 "
 269 <p>
 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.
 272 </p>
 273 <ul>
 274 <li>
 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.
 279 </li>
 280 <li>
 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.
 285 </li>
 286 <li>
 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.
 289 </li>
 290 <li>
 291 Use <code>Help</code> to open this dialog box.
 292 </li>
 293 </ul>
 294 "
 295
 296 type processor_function =
 297     (int -> int -> unit) ->      (** Tick *)
 298     (string * string) ->
 299     output list
 300
 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) ()
 306
 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 -> [])
 312   in
 313   let make_layout () =
 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.);
 319     pbar##setValue (0.);
 320     pbar##decorateInternal (elt);
 321
 322     let toolbar = jsnew Ui.toolbar (Js.null, Js.null, Js.null) in
 323     let tabbar  =
 324       jsnew Ui.tabBar (Js.some (Ui.TabBar.location_pre_of_location Ui.TabBar.START), Js.null, Js.null)
 325     in
 326
 327     let get_selected_input () =
 328       try
 329         let tab =  (Js.Opt.get (tabbar##getSelectedTab ()) impossible) in
 330         let caption = (Js.Opt.get (tab##getCaption ()) impossible) in
 331         Some (caption)
 332       with _ -> None
 333     in
 334     menu_ref :=
 335       new_menu toolbar " Create from ..." []
 336       (fun choice ->
 337         try
 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);
 342
 343     new_button toolbar "Run"       (fun () ->
 344       match get_selected_input () with
 345         | None ->
 346           Firebug.console##log (Js.string "Nothing to run!")
 347
 348         | Some selected_input ->
 349           let run () =
 350           Firebug.console##log ((Js.string "Process the source named ")##concat (selected_input));
 351
 352             let interface =
 353               try
 354                 Hashtbl.find input_interfaces selected_input
 355               with Not_found -> assert false
 356             in
 357             interface.clear_output_tabs ();
 358             let tick =
 359               fun step over ->
 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)));
 362                 pbar##setValue (v);
 363                 elt_txt##innerHTML <- Js.string (string_of_float v ^ "%")
 364             in
 365             let outputs =
 366               try
 367                 let title, contents = interface.get_input () in
 368                 !processor_ref tick (Js.to_string title, Js.to_string contents)
 369               with exn ->
 370                 [("Error", Printexc.to_string exn)]
 371             in
 372             interface.new_output_tabs
 373               (List.map (fun (t, o) -> (Js.string t, Js.string o)) outputs);
 374             Lwt.return ()
 375           in
 376           push_processing run
 377     );
 378
 379     new_button toolbar "Close"     (fun () ->
 380       match get_selected_input () with
 381         | None ->
 382           Firebug.console##log (Js.string "Nothing to close!")
 383         | Some selected_input ->
 384           Firebug.console##log ((Js.string "Closing ")##concat (selected_input));
 385             let interface =
 386               try
 387                 Hashtbl.find input_interfaces selected_input
 388               with Not_found -> assert false
 389             in
 390             interface.close ()
 391       );
 392
 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)
 397     );
 398
 399     tabbar##decorate (get_element (Js.string "maintabbar"));
 400     toolbar##render (Js.some (get_element (Js.string "maintoolbar")))
 401   in
 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
 405   in
 406   let register_processor p =
 407     processor_ref := p
 408   in
 409   make_layout, add_inputs, register_processor
 410
 411 let loaded = ref Js._false
 412
 413 let rec load = function
 414   | [] ->
 415     Lwt.return []
 416   | Direct (title, contents) :: is ->
 417     load is
 418     >>= (fun is -> Lwt.return ((title, contents) :: is))
 419   | Url url :: is ->
 420     load_input_from_url url
 421     >>= (fun url_is ->
 422       load is
 423       >>= (fun is -> Lwt.return (url_is @ is)))
 424
 425 let from_function inputs processor =
 426   let start _ =
 427     let rec wait_for_processing () =
 428       Lwt_condition.wait processing_queue_updated
 429         >>= next_processing
 430         >>= wait_for_processing
 431     in
 432     Lwt_js.sleep 0.2
 433     >>= (fun () -> load inputs)
 434     >>= fun inputs -> begin
 435       make_layout ();
 436       add_inputs inputs;
 437       register_processor processor;
 438       Firebug.console##log (Js.string "Loaded!");
 439       Lwt.return ()
 440     end
 441     >>= wait_for_processing
 442   in
 443   Dom_html.window##onload <- Dom_html.handler (fun _ -> ignore (start ()); Js._false)
 444