open Dom
open Dom_html
open Js
open Firebug
open Goog

let msgbox s = 
  console##log (s)

type input = 
  | Direct of string * (unit -> string)
  | Url of string

let children_of_node node = 
  let c = ref [] in
  for i = 0 to node##childNodes##length - 1 do 
    let node = Js.Opt.get (node##childNodes##item (i)) (fun _ -> assert false) in
    match node##nodeType with
      | Dom.DOCUMENT | Dom.DOCUMENT_FRAGMENT | Dom.ELEMENT | Dom.CDATA_SECTION ->
	c := node :: !c
      | _ -> ()
  done;
  List.rev !c

let contents_of_node (node : node Js.t) =
  let c = ref [] in
  match node##nodeType with
    | Dom.CDATA_SECTION ->
      let t = Js.Opt.get (Dom.CoerceTo.text (node :> node Js.t)) (fun _ -> assert false) in
      t##data
    | _ -> 
      for i = 0 to node##childNodes##length - 1 do 
	let node = Js.Opt.get (node##childNodes##item (i)) (fun _ -> assert false) in
	match node##nodeType with
	  | Dom.TEXT | Dom.CDATA_SECTION ->
	    c := node :: !c
	  | _ -> ()
      done;
      Js.Opt.get ((List.hd !c)##nodeValue) (fun _ -> Js.string "Error")

let (>>=) = Lwt.bind

let http_get url =
  XmlHttpRequest.get url >>= fun r ->
  let cod = r.XmlHttpRequest.code in
  let msg = r.XmlHttpRequest.content_xml () in
  if cod = 0 || cod = 200
  then Lwt.return msg
  else fst (Lwt.wait ())

let load_input_from_url url = 
  let extract_inputs frame = 
    match frame with
      | None -> 
	Dom_html.window##alert (Js.string "Loading of examples failed."); 
	[]
      | Some inputs_doc -> 
	let inputs_root = List.hd (children_of_node inputs_doc) in
	let inputs_nodes = children_of_node inputs_root in
	let inputs = List.map (fun n -> 
	  msgbox n;
	  let data = children_of_node n in
	  msgbox data;
	  let get i = Js.to_string (contents_of_node (List.nth data i)) in
	  (get 0, fun () -> get 1))
	  inputs_nodes
	in
	inputs
  in
  Lwt.catch (fun () -> http_get url
		       >>= (fun frame -> 
			 Lwt.return (extract_inputs frame)))
    (function _ -> 
      Lwt.return []
    )

type output = (string * string)

let impossible _ = assert false
  
let ccs s = Goog.Ui.ControlContent.string (Js.string s)

let add_item s (m : Goog.Ui.menu Js.t) = 
  m##addItem (Goog.Tools.Union.i1 jsnew Goog.Ui.menuItem (ccs s, Js.null, Js.null))

let get_element s = 
  Js.Opt.get 
    (Dom_html.document##getElementById (s))
    (fun _ -> Dom_html.window##alert (s); assert false)

let new_tab tabbar label = 
  let tab = jsnew Ui.tab (Ui.ControlContent.string label, Js.null, Js.null) in
  Ui.Component.addChild tabbar tab (Js.some Js._true);
  tab

let new_button toolbar label onclick = 
  let button = 
    jsnew Ui.toolbarButton 
      (Ui.ControlContent.string (Js.string label), 
       Js.null,
       Js.null)
  in
  Ui.Component.addChild toolbar button (Js.some Js._true);
  ignore 
    (Events.listen 
       (Tools.Union.i1 button) 
       (Js.string "action") 
       (Js.wrap_callback (fun _ -> onclick ())) 
       Js.null)

let new_menu toolbar label entries onchange = 
  let menu = jsnew Goog.Ui.menu (Js.null, Js.null) in
  List.iter (fun s -> add_item s menu) entries;
  let menu_button = 
    jsnew Ui.toolbarMenuButton
      (Ui.ControlContent.string (Js.string label), 
       Js.some menu,
       Js.null,
       Js.null)
  in
  ignore 
    (Events.listen 
       (Tools.Union.i1 menu_button) 
       (Js.string "action")
       (Js.wrap_callback (fun e -> 
	 let get x : Goog.Ui.menuItem Js.t = 
	   Js.Unsafe.coerce (Js.Optdef.get x (fun _ -> assert false))
	 in
	 onchange ((get (e##target))##getCaption ())))
       Js.null);

  Ui.Component.addChild toolbar menu_button (Js.some Js._true);
  menu

type input_interface = {
  get_input : unit -> Js.js_string Js.t * Js.js_string Js.t;
  new_output_tabs   : (Js.js_string Js.t * Js.js_string Js.t) list -> unit;
  clear_output_tabs : unit -> unit;
  close : unit -> unit
}

let input_interfaces : (Js.js_string Js.t, input_interface) Hashtbl.t = 
  Hashtbl.create 13

let fresh_name n = 
  let rec aux i = 
    let name = if i = 0 then n else (n##concat (Js.string (string_of_int i))) in
    if Hashtbl.mem input_interfaces name then
      aux (i + 1)
    else 
      name
  in
  aux 0

let new_input (tabbar : Ui.tabBar Js.t) choice (contents : Js.js_string Js.t) = 

  let choice = fresh_name choice in

  let tab_contents = get_element ((Js.string "maintabbar_content")) in

  let source_label = choice##concat (Js.string "_source") in
  let content_label = choice##concat (Js.string "_contents") in

  let tab                             = new_tab tabbar choice in
  let tab_frame                 = Dom_html.createDiv (Dom_html.document) in
  let subtab_frame           = Dom_html.createDiv (Dom_html.document) in
  let contents_tab_frame = Dom_html.createDiv (Dom_html.document) in
  let clear_tab_frame       = Dom_html.createDiv (Dom_html.document) in
  let subtabs = 
    jsnew Ui.tabBar (
      Js.some (Ui.TabBar.location_pre_of_location Ui.TabBar.BOTTOM),
      Js.null, 
      Js.null) 
  in 
  contents_tab_frame##className <- Js.string "goog-tab-content";
  contents_tab_frame##id		   <- content_label;
  subtab_frame##className	   
   <- Js.string "goog-tab-bar goog-tab-bar-start";
  clear_tab_frame##className	   <- Js.string "goog-tab-bar-clear";

  subtabs##decorate                       ((subtab_frame :> Dom_html.element Js.t));
  ignore (tab_frame##appendChild ((subtab_frame :> Dom.node Js.t)));
  ignore (tab_frame##appendChild ((contents_tab_frame :> Dom.node Js.t)));
  ignore (tab_frame##appendChild ((clear_tab_frame :> Dom.node Js.t)));

  (* Source code editor. *)
  let text = Dom_html.createTextarea (Dom_html.document) in 
  text##className <- Js.string "editor";
  text##value <- contents;

  let change_tab_content node = 
    if contents_tab_frame##hasChildNodes () = _true then 
      ignore (contents_tab_frame##removeChild 
		(Js.Opt.get contents_tab_frame##firstChild impossible));
    ignore (contents_tab_frame##appendChild (node))
  in

  let input_tab = new_tab subtabs source_label in 
  ignore 
    (Events.listen 
       (Tools.Union.i1 input_tab) 
       (Js.string "select")
       (Js.wrap_callback (fun e -> change_tab_content ((text :> Dom.node Js.t))))
       Js.null);

  ignore 
    (Events.listen 
       (Tools.Union.i1 tab) 
       (Js.string "select")
       (Js.wrap_callback (fun e ->
	 if tab_contents##hasChildNodes () = _true then 
	   ignore (tab_contents##removeChild 
		     (Js.Opt.get tab_contents##firstChild impossible));
	 ignore (tab_contents##appendChild ((tab_frame :> Dom.node Js.t)))))
       Js.null);

  tabbar##setSelectedTab   (Js.some tab);
  subtabs##setSelectedTab (Js.some input_tab);

  let get_input () = 
    (choice, text##value)
  in

  let output_tabs = ref [] in

  let new_output_tabs outputs = 
    let new_output_tab (title, value) = 
      let output_tab = new_tab subtabs (choice##concat (title)) in
      let output_frame = Dom_html.createDiv (Dom_html.document) in
      output_tabs := output_tab :: !output_tabs;
      let text = Dom_html.createTextarea (Dom_html.document) in 
      text##className <- Js.string "editor";
      text##value <- value;
      ignore (output_frame##appendChild ((text :> Dom.node Js.t)));
      ignore 
	(Events.listen 
	   (Tools.Union.i1 output_tab) 
	   (Js.string "select")
	   (Js.wrap_callback (fun e -> 
	     change_tab_content ((output_frame :> Dom.node Js.t))))
	   Js.null)
    in
    List.iter new_output_tab outputs
  in
  
  let clear_output_tabs () = 
    List.iter (fun tab -> 
      ignore (subtabs##removeChild (Goog.Tools.Union.i2 tab, Js.some Js._true))) 
      !output_tabs;
    output_tabs := []
  in

  let close () = 
    Hashtbl.remove input_interfaces choice;
    ignore (contents_tab_frame##removeChild ((text :> Dom.node Js.t)));
    subtabs##disposeInternal ();
    ignore (tabbar##removeChild (Goog.Tools.Union.i2 tab, Js.some Js._true))
  in
  Hashtbl.add input_interfaces choice
  {
    get_input               = get_input;
    new_output_tabs   = new_output_tabs;
    clear_output_tabs = clear_output_tabs;
    close			  = close;
  }
  
let help_message = 
"
<p>
Please be aware of the limited computational power of JavaScript. Your O'Caml
program will run 10 times slower than a natively compiled one.
</p>
<ul>
<li>
Use <code>Create from...</code> to load 
a predefined input. This should create a tab in the
interface for this specific instance of the input. You
can freely edit this input in the text area. 
</li>
<li>
Use <code>Run</code> to process the input. This should create
a set of tabs to store the outputs. You can use 
<code>Run</code> several times: the outputs will be refreshed
if the input has changed. 
</li>
<li>
Use <code>Close</code> to dispose the input instance corresponding
to the selected tab. Be aware that you will lost your local modifications. 
</li>
<li>
Use <code>Help</code> to open this dialog box.
</li>
</ul>
" 

type processor_function =
    (int -> int -> unit) ->      (** Tick *)
    (string * string) -> 
    output list

let processing_queue_updated = Lwt_condition.create ()
let q = Queue.create ()
let push_processing f = 
  Queue.push f q; Lwt_condition.signal processing_queue_updated ()
let next_processing () = (Queue.take q) ()

let make_layout, add_inputs, register_processor = 
  let menu_ref      = ref (Obj.magic 0) in
  let inputs_ref    : (Js.js_string Js.t * (unit -> Js.js_string Js.t)) list ref = ref [] in
  let processor_ref : processor_function ref = 
    ref (fun tick s -> []) 
  in
  let make_layout () = 
    let pbar = jsnew Ui.progressBar () in
    let elt = get_element (Js.string "progressbar") in
    let elt_txt = get_element (Js.string "progressbarin") in
    pbar##setMaximum (100.);
    pbar##setMinimum (0.);
    pbar##setValue (0.);
    pbar##decorateInternal (elt); 

    let toolbar = jsnew Ui.toolbar (Js.null, Js.null, Js.null) in
    let tabbar  = 
      jsnew Ui.tabBar (Js.some (Ui.TabBar.location_pre_of_location Ui.TabBar.START), Js.null, Js.null) 
    in

    let get_selected_input () = 
      try 
	let tab =  (Js.Opt.get (tabbar##getSelectedTab ()) impossible) in
	let caption = (Js.Opt.get (tab##getCaption ()) impossible) in 
	Some (caption)
      with _ -> None
    in
    menu_ref := 
      new_menu toolbar " Create from ..." [] 
      (fun choice -> 
	try 
	  let choice   = Js.Opt.get choice (fun _ -> assert false) in
	  let contents = (List.assoc choice !inputs_ref) () in
	  new_input tabbar choice contents
       with _ -> assert false);
    
    new_button toolbar "Run"       (fun () -> 
      match get_selected_input () with
	| None -> 
	  Firebug.console##log (Js.string "Nothing to run!") 
	  
	| Some selected_input -> 
	  let run () = 
	  Firebug.console##log ((Js.string "Process the source named ")##concat (selected_input));
	    
	    let interface = 
	      try 
		Hashtbl.find input_interfaces selected_input  
	      with Not_found -> assert false
	    in 
	    interface.clear_output_tabs ();
	    let tick =
	      fun step over ->
		let v = 100. *. float_of_int step /. float_of_int over in
		Firebug.console##log ((Js.string ("Step " ^ string_of_int step ^ " " ^ string_of_float v)));
		pbar##setValue (v);
		elt_txt##innerHTML <- Js.string (string_of_float v ^ "%")
	    in
	    let outputs = 
	      try 
		let title, contents = interface.get_input () in
		!processor_ref tick (Js.to_string title, Js.to_string contents) 
	      with exn ->
		[("Error", Printexc.to_string exn)]
	    in
	    interface.new_output_tabs 
	      (List.map (fun (t, o) -> (Js.string t, Js.string o)) outputs);
	    Lwt.return ()
	  in
	  push_processing run
    );

    new_button toolbar "Close"     (fun () -> 
      match get_selected_input () with
	| None -> 
	  Firebug.console##log (Js.string "Nothing to close!")
	| Some selected_input -> 
	  Firebug.console##log ((Js.string "Closing ")##concat (selected_input));
	    let interface = 
	      try 
		Hashtbl.find input_interfaces selected_input  
	      with Not_found -> assert false
	    in 
	    interface.close ()
      );

    new_button toolbar "Help"     (fun () -> 
	let dialog = jsnew Ui.dialog (Js.null, Js.null, Js.null) in
	dialog##setContent (Js.string help_message);
	dialog##setVisible (Js._true)
    );
    
    tabbar##decorate (get_element (Js.string "maintabbar"));
    toolbar##render (Js.some (get_element (Js.string "maintoolbar")))    
  in
  let add_inputs inputs = 
    List.iter (fun (s, _) -> add_item s !menu_ref) inputs;
    inputs_ref := List.map (fun (k, v) -> (Js.string k, fun () -> Js.string (v ()))) inputs
  in
  let register_processor p = 
    processor_ref := p
  in
  make_layout, add_inputs, register_processor

let loaded = ref Js._false 

let rec load = function
  | [] -> 
    Lwt.return []
  | Direct (title, contents) :: is -> 
    load is 
    >>= (fun is -> Lwt.return ((title, contents) :: is))
  | Url url :: is -> 
    load_input_from_url url 
    >>= (fun url_is ->
      load is 
      >>= (fun is -> Lwt.return (url_is @ is)))

let from_function inputs processor = 
  let start _ = 
    let rec wait_for_processing () =
      Lwt_condition.wait processing_queue_updated 
	>>= next_processing 
	>>= wait_for_processing 
    in
    Lwt_js.sleep 0.2 
    >>= (fun () -> load inputs)
    >>= fun inputs -> begin
      make_layout ();
      add_inputs inputs;
      register_processor processor;
      Firebug.console##log (Js.string "Loaded!");
      Lwt.return ()
    end
    >>= wait_for_processing
  in
  Dom_html.window##onload <- Dom_html.handler (fun _ -> ignore (start ()); Js._false)