(* Tk based FormDisplay  *)
open Printf
open Tk
open Hyper
open Www
open Html
open Htmlfmt
open Maps
open Embed
open Viewers

type t = {
  text_input : Widget.widget -> tag -> unit;
      (* [text_input top tag] *)
  checkbox_input : Widget.widget ->  tag -> unit;
      (* [input top tag] *)
  radio_input : Widget.widget ->  tag -> unit;
      (* [input top tag] *)
  image_input : Widget.widget ->  tag -> embobject;
      (* [input top tag] *)
  submit_input : Widget.widget ->  tag -> unit;
      (* [input top tag] *)
  reset_input : Widget.widget ->  tag -> unit;
      (* [input top tag] *)
  select : Widget.widget -> (string * string * bool) list -> tag -> unit;
      (* [select top elements tag] *)
  textarea:  Widget.widget -> string -> tag -> unit
      (* [textarea top initial attrs] *)
  }


(* mapi (fun n x -> ...) n0 l *)
let rec mapi f n l =
  match l with
    [] -> [] 
  | x::l -> let v = f n x in v::(mapi f (succ n) l)


(* A TEXT or PASSWORD input *)
(* TODO: MAXLENGTH *)
(* TODO: if the only one, then submit *)
let text_input behav top tag =
  try
    let name = get_attribute tag "name"
    and inputtype = get_attribute tag "type" in
    (* Create an entry widget *)
    let e = Entry.create top [ExportSelection false] in
    (* Check for size *)
    begin try 
     let s = get_attribute tag "size" in
      try Entry.configure e [TextWidth (int_of_string s)]
      with Failure "int_of_string" ->
	 Log.f (Printf.sprintf "%s not a valid val for SIZE" s)
    with Not_found -> ()
    end;
    (* Check for passwd *)
    if inputtype = "PASSWORD" then Entry.configure e [Show '*'];
    (* The behaviours *)
    let reset = 
      try
	let v = get_attribute tag "value" in
	 Entry.insert e End v;
	 (fun () -> Entry.delete_range e (Number 0) End;
		    Entry.insert e End v)
      with Not_found ->
	 (fun () -> Entry.delete_range e (Number 0) End)
    (* spec says we could omit if empty *)
    and get_value () = [name, Entry.get e]
    in
      pack [e][];
      behav#add_get get_value;
      behav#add_reset reset
  with
    Not_found ->
      raise (Invalid_Html "Missing NAME in TEXT or PASSWORD")


(* A CHECKBOX input *)
let checkbox_input behav top tag =
  try
    let name = get_attribute tag "name" in
    let v = Textvariable.create_temporary top in
    let c = Checkbutton.create top [Variable v] in   (* variable val is 1/0 *)
    let reset =
      if has_attribute tag "checked" then begin
	Checkbutton.select c;
	(fun () -> Checkbutton.select c)
	end
      else (fun () -> Checkbutton.deselect c)
    and get_value =
      let value = 
	try get_attribute tag "value" 
	with Not_found ->
	 Log.f "no VALUE given for input CHECKBOX, using \"unknown\"";
	 "unknown" in
      (* spec says we SHOULD omit when not selected *)
      (fun () -> 
	 match Textvariable.get v with 
	   "1" -> [name, value]
	 | _ -> [])
    in
      pack [c][];
      behav#add_get get_value;
      behav#add_reset reset
  with
    Not_found ->
      raise (Invalid_Html "Missing NAME in CHECKBOX")


(* A RADIO input *)
(* ONLY THE FIRST BUTTON RESET/GET_VALUE IS USED *)
let radio_input behav = 
  (* Table of radio names *)
  let radios = Hashtbl.create 17 in
  (fun top tag ->
     try
       let name = get_attribute tag "name" in
       let r = Radiobutton.create top []
       and checked = has_attribute tag "checked"
       and va = try get_attribute tag "value" with Not_found -> "unknown"
       in
       try
	 let v, sel = Hashtbl.find radios name in
	   (* We already have a radiobutton with this name *)
	   Radiobutton.configure r [Variable v; Value va];
	   if checked then begin 
	     Radiobutton.select r; (* select it *)
	     sel := r (* store it in table for reset *)
	   end;
	   (* no need to add behaviour *)
	   pack [r][]
       with
	 Not_found ->
	   (* this is the first radio button with this name *)
	   (* it this thus assumed checked *)
	    let v = Textvariable.create_temporary top in
	     Hashtbl.add radios name (v, ref r);
	    let get_value () = [name, Textvariable.get v]
	    and reset () = 
	       (* to reset, we must lookup the table *)
	      let _, sel = Hashtbl.find radios name in
		Radiobutton.select !sel 
	    in
	    Radiobutton.configure r [Variable v; Value va];
	    Radiobutton.select r; (* assume selected *)
	    pack [r][];
	    behav#add_get get_value;
	    behav#add_reset reset
    with
      Not_found ->
	raise (Invalid_Html "Missing NAME in RADIO"))


(* An IMAGE input *)
let image_input ctx base behav top tag =
  try
    let n = get_attribute tag "name" in
    let src = get_attribute tag "src" in
    let alt = 
       try get_attribute tag "alt"
       with Not_found -> "[INPUT IMAGE]"
    in
      {
      embed_hlink = { h_uri = src; h_context = Some base; h_method = GET};
      embed_frame = top;
      embed_context = ctx; (* pass as is... *)
      embed_map = FormMap (fun (x, y) ->
			     let subargs =
				 [sprintf "%s.x" n, string_of_int x;
				  sprintf "%s.y" n, string_of_int y] in
			       behav#submit subargs);
      embed_alt = alt}
  with
  Not_found ->
    raise (Invalid_Html "missing NAME or SRC in input IMAGE")


(* A Submit button *)
let submit_input ctx behav top tag = 
  let l = 
    try get_attribute tag "value"
    with Not_found -> I18n.sprintf "Submit"
  and goto = List.assoc "goto" ctx.viewer_hyper
  in
  try
    let n = get_attribute tag "name" in
    pack [Button.create top [Text l;
	     Command (fun () -> goto.hyper_func (behav#submit [n,l]))]]
         []
  with
    Not_found ->
     (* if name is not present, the button does not contribute a value *)
     pack [Button.create top [Text l;
	      Command (fun () -> goto.hyper_func (behav#submit []))]]
	  []


let reset_input behav top tag = 
  let l = 
    try get_attribute tag "value"
    with Not_found -> I18n.sprintf "Reset" in
  let b = Button.create top [Text l; 
			     Command (fun () -> behav#reset)] in
    pack[b][]



 (* TODO: FILE (RFC 1867) *)



(* A SELECT list *)
(* options is: (val, displayed thing, selected) list *)    
let select behav top options tag =
  let name = get_attribute tag "name" in
  let ssize = get_attribute tag "size" in
  let size =
     try int_of_string ssize
     with _ -> 
	Log.f (Printf.sprintf "%s not a valid val for SIZE\n" ssize);
	5 in
  let multiple = has_attribute tag "multiple" in
  if size = 1 & not multiple then begin
    (* use an optionmenu *)
    let vard = Textvariable.create_temporary top   (* var to display *)
    and varv = Textvariable.create_temporary top   (* var for val *)
    in
    let m = Menubutton.create top 
	       [TextVariable vard; Relief Raised; Anchor Center] in
    let mmenu = Menu.create m [TearOff false] in
     Menubutton.configure m [Menu mmenu];
     let initial =
       match options with
	 [] -> raise (Invalid_Html ("No OPTION in SELECT"))
       | opt :: _ -> ref opt in
     List.iter (function (v,d,s) as x ->
		Menu.add_command mmenu
		    [Label d;
		     Command (fun () -> 
			       Textvariable.set varv v;
			       Textvariable.set vard d
			      )];
		if s then initial := x
		)
	      options;
     let reset () =
       match !initial with
	(v,d,_) -> 
	     Textvariable.set varv v;
	     Textvariable.set vard d
     and get_value () = [name, Textvariable.get varv] in
       reset();
       pack [m][];
       behav#add_get get_value;
       behav#add_reset reset
     end
  else begin (* use a listbox *)
   (* listbox indices start at 0 *)
   (* we must not ExportSelection, otherwise one unique listbox can *)
   (* have a current selection *)
    let nth_entry n l =
      let (v,_,_) = List.nth l n in v in
    let f,lb = Frx_listbox.new_scrollable_listbox top 
      [TextHeight size; TextWidth 0; (* automatic size *)
       (if multiple then SelectMode Multiple else SelectMode Single);
       ExportSelection false] in
    let initial = ref [] in
    let entries =
     mapi (fun i (_,v,s) -> 
	       if s then initial := i :: !initial;
	       v) 0 options in
      Listbox.insert lb End entries;
    if !initial = [] then initial := [0];
    let reset () = 
       Listbox.selection_clear lb (Number 0) End;
       List.iter (fun i ->
		 Listbox.selection_set lb (Number i)(Number i))
	       !initial
    and get_value () =
       List.map (function
	      Number n -> name, nth_entry n options
	    | _ -> name, nth_entry 0 options (* fatal error ! *))
	   (Listbox.curselection lb)
    in
      reset (); 
      pack [f][];
      behav#add_reset reset;
      behav#add_get get_value
    end

let textarea behav top initial tag = 
  try 
    let name = get_attribute tag "name" in
    let f,t = 
       Frx_text.new_scrollable_text top [ExportSelection false] false in
    begin try
      let w = get_attribute tag "cols" in
      try Text.configure t [TextWidth (int_of_string w)]
      with Failure "int_of_string" ->
	Log.f (Printf.sprintf "%s not a valid val for COLS\n" w)
    with Not_found -> ()
    end;
    begin try
      let h = get_attribute tag "rows" in
      try Text.configure t [TextHeight (int_of_string h)]
      with Failure "int_of_string" ->
	Log.f (Printf.sprintf "%s not a valid val for ROWS\n" h)
    with Not_found -> ()
    end;
    Text.insert t Frx_text.textEnd initial [];
    let reset () =
      Text.delete t (TextIndex(LineChar(0,0), [])) Frx_text.textEnd;
      Text.insert t Frx_text.textEnd initial []
    and get_value () =
      [name, Text.get t (TextIndex(LineChar(0,0), [])) 
		   (TextIndex(End, [CharOffset (-1)]))]
    in
       pack [f][];
       behav#add_reset reset;
       behav#add_get get_value
  with
    Not_found -> raise (Invalid_Html "Missing NAME in TEXTAREA")


let create base behav ctx =
  { text_input = text_input behav;
    checkbox_input = checkbox_input behav;
    radio_input = radio_input behav;
    image_input = image_input ctx base behav;
    submit_input = submit_input ctx behav;
    reset_input = reset_input behav;
    select = select behav;
    textarea = textarea behav
  }
