open Printf
open Tk
open Frx_text
open Hyper
open Viewers
open Html
open Htmlfmt
open Fonts


(* Text widget formatter for the HTML Display Machine
 * The main function builds a GfxHTML, in two cases
 *    1- normal (viewing an HTML document)
 *    2- nested (a cell in a table)
 *)

let html_bg = ref "white"
let html_fg = ref "black"

let pscrolling = ref false

let usecolors = ref true

(* Simplified formatter: if there is only text, then use a label *)
(* otherwise, use a true formatter in a text widget. This is going to
   be real costly *)

let delayed w font real =
  let state = ref None
  and memory = ref "" in
  let ohno () =
    match !state with
      None -> let f = real() in 
		state := Some f;
		f.format_string !memory;
		f		
    | Some f -> f in
  {new_paragraph = (fun x -> (ohno()).new_paragraph x);
   close_paragraph = (fun x -> (ohno()).close_paragraph x);
   print_newline = (fun x -> (ohno()).print_newline x);
   print_verbatim = (fun x -> (ohno()).print_verbatim x);
   format_string = (fun x -> 
		      match !state with
			 None -> memory := x
		       | Some f -> f.format_string x);
   flush = 
    (let flushed = ref false in		(* in case we flush twice... *)
     (fun () ->
        if not !flushed then begin
	  flushed := true;
	  match !state with
	    None -> (* haha *)
	      let txt = Html.beautify true !memory in
	      let txt = if txt = "" then " " else txt in
	      let l = Message.create w 
		  ([Anchor Center; Text txt; BorderWidth (Pixels 0);
		   PadX (Pixels 2); Justify Justify_Center]@font) in
		  pack [l] [Fill Fill_Both; Expand true]
	  | Some f -> f.flush()
         end));
   hr = (fun x -> (ohno()).hr x);
   bullet = (fun x -> (ohno()).bullet x);
   set_defaults = (fun x  -> (ohno()).set_defaults x);
   push_attr = (fun x -> (ohno()).push_attr x);
   pop_attr = (fun x -> (ohno()).pop_attr x);
   isindex = (fun x -> (ohno()).isindex x);
   start_anchor = (fun x -> (ohno()).start_anchor x);
   end_anchor = (fun x -> (ohno()).end_anchor x);
   add_mark = (fun x -> (ohno()).add_mark x);
   create_embedded = (fun a w h -> (ohno()).create_embedded a w h);
   cell_formatter = (fun x -> (ohno()).cell_formatter x);
   see_frag = (fun x -> ())
   }

(* Build a formatter, as required by html_disp *)
type formatterSpec = TopFormatter | NestedFormatter

let rec tformat spec top ctx =
  let fhtml, thtml =
    match spec with
      TopFormatter ->
      	if !pscrolling then begin
         let f,t = 
           Frx_ctext.create top [Wrap WrapWord; State Disabled] true in
      	   Canvas.configure (Winfo.parent t)
	                    [Background (NamedColor !html_bg)];
	   f, t
         end
	else
          new_scrollable_text top 
      	     [Wrap WrapWord; State Disabled]
             true 
    | NestedFormatter -> (* Embedded formatters (tables) *)
      let t = Text.create top 
      	 [TextHeight 1; TextWidth 3; 
      	  BorderWidth (Pixels 0); State Disabled; 
          Relief Flat; Wrap WrapWord] in
        pack [t][Expand true; Fill Fill_Both];
        top, t
  in
  (* Tk4.0pl3 fix, + avoid cb to scrollbar *)
  Text.configure thtml [TakeFocus true; InsertOffTime 0];

  (* Make the widget searchable *)
  if spec = TopFormatter then Frx_text.addsearch thtml;

  (* Set (other) defaults *)
  let _, html_font = Fonts.compute_tag !Fonts.default in
   Text.configure thtml html_font;
  if !Version.japan then begin
    let _, html_jfont = Jfonts.compute_tag !Fonts.default in
      Jtk.Kanji.widget_kanjifont thtml html_jfont
    end;

  (* transparent GIF hack *)
  Protocol.tkEval 
    [|Protocol.TkToken "set";
      Protocol.TkToken "TRANSPARENT_GIF_COLOR";
      Protocol.TkToken !html_bg |];

  (* Hypertext Anchor support *)
  let htobj = new Htbind.hypertext thtml in
   htobj#init ctx;

  (* Missing from the old version:
	  Text.tag_configure thtml atag 
		   [Foreground (NamedColor "MidnightBlue")];
     and Motion bind
   *)

  (* For imagemaps and forms *)
  let navigate = 
    try 
      (List.assoc "goto" ctx.viewer_hyper).hyper_func
    with
      Not_found -> (fun _ -> ()) in
 
  (* The formatter
   *    to minimize calls to Tk, we write only one string for 
   * each paragraph larger than some size. Because of this, it seems
   * that we also have to set tags and marks at the end.
   *)

  (* Things queued *)
  let marks = ref []
  and embedded = ref []
  and tagdefs = new Attrs.tags thtml
  and jtagdefs = new Jattrs.tags thtml

  and position = ref 0  		(* not easy to use a text index ! *)
  and anchor_start = ref 0

  (* Paragraphs and space squeezing *)
  and trailing_space = ref false
  and prev_is_newline = ref false
      (* if this is false, we are displaying text. if this is true, we
         just issued a newline *)
  in

  (* Size of buffer can impact performances *)
  let refresh_threshold = 10000 in
  let buffer = Ebuffer.create (2 * refresh_threshold)
  and last_flush = ref !Low.global_time in

  let internal_flush refresh = (* flush the buffer *)
     last_flush := !Low.global_time;
     Text.configure thtml [State Normal];
     Text.insert thtml textEnd (Ebuffer.get buffer) [];
     Text.configure thtml [State Disabled];
     Ebuffer.reset buffer;
     List.iter 
         (function (opts,p) -> Text.window_create thtml (abs_index p) opts)
	 (List.rev !embedded);
     List.iter (function (m,p) -> Text.mark_set thtml m (abs_index p)) !marks;
     tagdefs#flush;
     if !Version.japan then jtagdefs#flush;
     marks := [];
     embedded := [];
     if refresh then update_idletasks()
     in

  let put_text s =
    match String.length s with
      0 -> ()
    | l ->
        position := !position + 
		    if !Version.japan then Japan.length s else l;
        prev_is_newline := false;
        Ebuffer.output_string buffer s;
	trailing_space := s.[l-1] = ' ';
	if  !Low.global_time > !last_flush + 4 (* it's been a while *)
	then internal_flush true
	else if  Ebuffer.used buffer > refresh_threshold 
	then internal_flush false
       in

  (* Logic for tag manipulation *)
  let margins = new Attrs.margin tagdefs
  and aligns = new Attrs.align tagdefs
  and fonts = new Attrs.font tagdefs
  and fgcolors = new Attrs.fgcolor tagdefs
  and bgcolors = new Attrs.bgcolor tagdefs
  and spacing = new Attrs.spacing tagdefs
  and offset = new Attrs.offset tagdefs
  and underline = new Attrs.misc (tagdefs, "underline", [Underline true])
  and strike = new Attrs.misc (tagdefs, "strike", [OverStrike true])
  and jfonts = new Jattrs.font jtagdefs

  in
  let put_embedded w align =
    let opts = match Mstring.uppercase align with
      "TOP" -> [Align Align_Top]
    | "MIDDLE" -> [Align Align_Center] (* not exactly *)
    | "BOTTOM" -> [Align Align_Baseline] 
    |  _ -> [] in
    embedded := ((Window w)::opts, !position) :: !embedded;
    prev_is_newline := false;
    incr position    (* an embedded window is one char wide *)    
  in

  let break () =
     if not !prev_is_newline then begin
       put_text "\n"; prev_is_newline := true
       end
  in

  let formatter =           
  { new_paragraph = (function () -> break(); spacing#push !position 5);
    close_paragraph = (function () -> spacing#pop !position  5; break());
    print_newline = (function force -> 
      if force then begin
        put_text "\n"; 
	prev_is_newline := false;
	trailing_space := true
       end
      else break()
      );
    print_verbatim = (function s -> put_text s; prev_is_newline := false);

    format_string = 
      (function s -> 
      	 if not !prev_is_newline then (* we are in text *)
      	    put_text (Html.beautify !trailing_space s)
	 else (* decide if we should start a text *)
      	  let bs = Html.beautify true s in
	    if bs = "" then () (* it was all spaces *)
	    else begin
	      put_text bs;
	      prev_is_newline := false
	    end);

    flush = 
      (function () -> internal_flush true);

    hr = (function () -> 
      	   put_embedded (Label.create thtml [Hr.image ""; 
					     BorderWidth (Pixels 0)]) "");

    (* TODO *)
    bullet = 
     (function s -> 
       try let img = Hashtbl.find Attrs.bullet_table s in
         put_embedded (Label.create thtml [img; BorderWidth (Pixels 0)]) ""
       with Not_found  -> put_text "*");

    (* TODO *)
    set_defaults = 
      (function l -> 
	  if !usecolors then
	  List.iter (function
		       BgColor s ->
			 let c = Attrs.html_color s in
			 if Frx_color.check c then begin
			   Resource.add 
			     (sprintf "Mmm%s*background" (Widget.name thtml))
				   c Interactive;
			     Text.configure thtml [Background (NamedColor c)]
                           end
		      | FgColor s ->
			 let c = Attrs.html_color s in
			 if Frx_color.check c then begin
			   Resource.add 
			     (sprintf "Mmm%s*foreground" (Widget.name thtml))
				   c Interactive;
			      Text.configure thtml [Foreground (NamedColor c)]
			   end
		      | _ -> ()   )
                    l);
    
    push_attr =
      (function l ->
        let fis = ref [] in
	  List.iter (function
		       Font fi -> fis := fi :: !fis
		     | Margin n -> margins#push !position n
		     | Justification a -> aligns#push !position a
                     | FgColor s -> fgcolors#push !position s
                     | BgColor s -> bgcolors#push !position s
                     | Spacing n -> spacing#push !position n
                     | Underlined -> underline#push !position
                     | Striked -> strike#push !position
                     | Superscript -> 
		          fis := (FontDelta (-2)) :: !fis;
		          offset#push !position 5
                     | Lowerscript ->
		          fis := (FontDelta (-2)) :: !fis;
		          offset#push !position (-5)
                     )
		    l;
          if !fis <> [] then begin
	    fonts#push !position !fis;
	    if !Version.japan then
	      jfonts#push !position !fis
	  end);
	
    pop_attr =
      (function l ->
        let fis = ref [] in
	  List.iter (function
		       Font fi -> fis := fi :: !fis
		     | Margin n -> margins#pop !position n
		     | Justification a -> aligns#pop !position a
                     | FgColor s -> fgcolors#pop !position s
                     | BgColor s -> bgcolors#pop !position s
                     | Spacing n -> spacing#pop !position n
                     | Underlined -> underline#pop !position
                     | Striked -> strike#pop !position
                     | Superscript ->
		          fis := (FontDelta (-2)) :: !fis;
		          offset#pop !position 5
                     | Lowerscript ->
		          fis := (FontDelta (-2)) :: !fis;
		          offset#pop !position (-5)
		    )
		    l;
          if !fis <> [] then begin
	    fonts#pop !position !fis;
	    if !Version.japan then jfonts#pop !position !fis
	  end);

    (* Compliance: text is not part of document ? *)
    isindex =
      (fun prompt base ->
	 let f,e = Frx_entry.new_label_entry thtml prompt
		    (function s -> 
		      navigate { h_uri = "?" ^ Urlenc.encode s;
				 h_context = Some base;
				 h_method = GET}) in
	  put_embedded f "";
	  put_text "\n");

    start_anchor =
      (fun () -> anchor_start := !position);
    end_anchor =
      (fun link ->
	  (* set the tag for the anchor *)
	  let tag = Mstring.gensym "anchor"
          and s = abs_index !anchor_start
          and e = abs_index !position in
	    tagdefs#add (tag, s, e);	(* for hyper activation *)
            tagdefs#add ("anchor", s, e); (* "display" style *)
	    htobj#add_anchor tag link
       );

    (* WARNING: if anchor name is a standard tk name, such as end,
       we're f*cked, so we force # *)
    add_mark = (fun s -> marks := ("#"^s, !position) :: !marks );

    create_embedded =
      (fun a w h ->
	 let f = Frame.create thtml [] in
	   (match w, h with
	     Some w, Some h ->
	       Frame.configure f [Width (Pixels w); Height (Pixels h)];
	       Pack.propagate_set f false
             | _, _ -> ());
	    put_embedded f "";
	    f);

    cell_formatter = 
      	(fun w ->
	  delayed w html_font (fun () ->
	    let formatter, _, tcell = 
	      tformat NestedFormatter w ctx in
	       formatter));
    see_frag =
      let prev_frag = ref false
      and view_mem = ref 0.0 in
      if !pscrolling then
       (function
	  None -> 
	  if !prev_frag then begin
	    try Canvas.yview (Winfo.parent thtml) (MoveTo !view_mem)
	    with Protocol.TkError _ -> ()
	  end;
	  prev_frag := false
	| Some s ->
	  if not !prev_frag then begin
	    try view_mem := fst (Canvas.yview_get (Winfo.parent thtml))
	    with Protocol.TkError _ -> ()
	  end;
	  prev_frag := true;
	  if s <> "" then
	   try
	   let _,y,_,_,_  = Text.dlineinfo thtml
				  (TextIndex (Mark ("#"^s), [LineOffset (-2)]))
	   and _,ye,_,_,_ = Text.dlineinfo thtml 
				  (TextIndex (End, [CharOffset (-1)])) in
	    Canvas.yview (Winfo.parent thtml) 
		  (MoveTo (float y /. float ye))
	  with Protocol.TkError _ -> ())
      else
	(function
	   None ->
	     if !prev_frag then begin
	       try Text.yview thtml (MoveTo !view_mem)
	       with Protocol.TkError _ -> ()
	     end;
	     prev_frag := false
	 | Some s -> 
	     if not !prev_frag then begin
	       try view_mem := fst (Text.yview_get thtml)
	       with Protocol.TkError _ -> ()
	     end;
	     prev_frag := true;
	     if s <> "" then
	       try Text.yview_index thtml 
		      (TextIndex (Mark ("#"^s), [LineOffset (-1)]))
	       with Protocol.TkError _ -> ())

    } in

  formatter, fhtml, thtml



let create w ctx =
 let fo, f, t = tformat TopFormatter w ctx in
  fo, f
