open Printf
open Tk
open Unix
open Document
open Hyper
open Html
open Html_eval
open Htmlfmt
open Textw_fo
open Viewers
open Feed

(* Pseudo HTML Widget:
 *  this is all the goodies *around* the basic text widget inside which
 *  the HTML document is displayed.
 *     - the title and this associated head menu
 *     - the progress report indicator
 *     - view/edit source of document
 * This is meant for building a "viewer"
 *)


class tcontext (pointstov,top,ctx,set_title) =
  val top = top
  val set_title = (set_title : string -> unit)
  val mutable menu =
     let m =
       Menubutton.create_named top "links" [Text "Links"; State Disabled] in
     let menu = Menu.create_named m "linkmenu" [] in
       pack [m][Side Side_Right];
       Menubutton.configure m [Menu menu];
       menu
  val v = pointstov
  val goto = 
    (try (List.assoc "goto" ctx.viewer_hyper).hyper_func 
     with _ -> (fun _ -> ()))
  val base = ctx.viewer_base

  method set_title title = set_title title

  method add_link title hlink =
     Menubutton.configure (Winfo.parent menu) [State Normal];
     Menu.add_command menu 
	[Label title; Command (fun () -> goto hlink)]

  method reset =
     destroy (Winfo.parent menu);
     let m =
       Menubutton.create_named top "links" [Text "Links"; State Disabled] in
     let newmenu = Menu.create_named m "linkmenu" [] in
       pack [m][Side Side_Right];
       Menubutton.configure m [Menu newmenu];
       menu <- newmenu
end
 


module F = Html_disp.Make(Textw_fo)(Imgload)(Form)(Table)

type html_widget =
  { widget : Widget.widget;
    display_token : Html.location -> Html.token -> unit;
    set_progress : int -> unit;
    see_fragment: string option -> unit;
    redisplay: unit -> unit;
    html_title : unit -> string;
    html_error : location -> string -> unit;
    html_source : unit -> unit;
    load_images : unit -> unit
    }

let headers_menu top v dh =
  let headers =
    Menubutton.create_named top "headers" [TextVariable v; TextWidth 80] in
  let headersm = Menu.create_named headers "menu" [] in
   Menubutton.configure headers [Menu headersm];
   List.iter 
    (function h ->
      	Menu.add_command headersm [Label h])
    (List.rev dh.document_headers);
  headers

(* Pseudo HTML widget *)
let create top ctx dh =
  let did = dh.document_id		(* we use it often *)
  and errors = ref [] 			(* storing error messages *)
  in
  let vgroup = Frame.create top [] in

  (* Menu bar with title and links *)
  let bargroup = Frame.create vgroup [] in
   (* The title of the document *)
   let titlev = Textvariable.create_temporary vgroup in
     Textvariable.set titlev (Url.string_of did.document_url);
   let headersb = headers_menu bargroup titlev dh in

  (* Progress report and pointsto *)
  let hgbas = Frame.create vgroup [] in
  let pointsto = Textvariable.create_temporary vgroup in
    let lpoint = 
      Label.create_named hgbas "pointsto"
      	[TextVariable pointsto; Anchor W]
    and fprog, set_progress = Frx_fillbox.new_horizontal hgbas 200 5

    in
      pack [fprog][Side Side_Left];
      pack [lpoint][Side Side_Left; Fill Fill_X];
      (* hack to avoid lpoint forcing the navigator to grow like hell *)
      Frame.configure hgbas
      	[Width (Pixels (Winfo.reqwidth (Winfo.toplevel hgbas)));
	 Height (Pixels (Winfo.reqheight lpoint))];
      Pack.propagate_set hgbas false;

  (* Setting the title *)
  let set_title t =
    let tl = Winfo.toplevel top
    and title = I18n.sprintf "MMM Navigator@%s" t in
      if Widget.known_class tl = "toplevel" then
      (Wm.title_set tl title; Wm.iconname_set tl title);
    Textvariable.set titlev t

  in
  (* Modified ctx, with pointsto added *)
  let ctx = {
    viewer_base = ctx.viewer_base;
    viewer_hyper = 
       ("pointsto" ,
	  {hyper_visible = false;
           hyper_title = "Show target";
	   hyper_func = (fun h -> 
	       let target = 
	          try Hyper.string_of h
		  with Invalid_link msg -> "invalid link" in
                Textvariable.set pointsto target)
	  }) :: 
       ("clearpointsto" ,
	  {hyper_visible = false;
           hyper_title = "Clear target";
	   hyper_func = (fun h -> Textvariable.set pointsto "")
	  }) :: ctx.viewer_hyper;
    viewer_log = ctx.viewer_log;
    viewer_params = []
     }
  in
  (* Scrollable text widget *)
  let hgroup = Frame.create_named vgroup "textw" [Class "Html"]
  and tcontext = new tcontext (pointsto, bargroup, ctx, set_title) in

    (* the text widget and its formatter *)
    let formatter, fhtml = Textw_fo.create hgroup ctx in

    (* IN THIS ORDER -- RESIZING *)
    pack [fhtml][Side Side_Left; Fill Fill_Both; Expand true];
    (* IN THIS ORDER -- RESIZING *)
    pack [headersb][Side Side_Left; Fill Fill_X];
    pack [bargroup][Fill Fill_X];
    pack [hgbas][Side Side_Bottom; Fill Fill_X];
    pack [hgroup][Fill Fill_Both; Expand true];
    

  (* Current display machine *)
  let dispmach =
     ref (F.create (did, ctx, (tcontext :> Html_disp.extracontext), formatter))
  and current_frame = ref fhtml 
  and current_formatter = ref formatter
  in
  (* finding out if the display machine has finished *)
  let pending = ref true in
  let send tok =
     if tok = EOF then pending := false;
     !dispmach#send tok
  in
  (* Redisplay the document. (if we have modified the source, or
     the preferences ... *)
  let redisplay () =
    if !pending then 
      Error.default#f (I18n.sprintf "Cannot redisplay document (pending)")
    else begin
      errors := [];
      (* We need to get the buffer from the cache, if the document was
	 reloaded for example. *)
	try
	  if Winfo.exists !current_frame then begin
            tcontext#reset;
	    let lexbuf =
	      match Cache.find did with
		 {document_data = FileData (n,_)} ->
		    Lexing.from_channel (open_in n)
	       | {document_data = MemoryData buffer} -> 
		    Lexing.from_string (Ebuffer.get buffer)
	    in
	    let formatter, fhtml = Textw_fo.create hgroup ctx  in
	     destroy !current_frame;
	     set_progress 0;
	     pack [fhtml] [Side Side_Left; Fill Fill_Both; Expand true];
	     current_frame := fhtml;
             current_formatter := formatter;
	     Tkwait.visibility fhtml;
	     dispmach :=
               F.create (did, ctx, (tcontext :> Html_disp.extracontext), 
                         formatter);
	     (* Display it *)
	     Html_eval.automat !Dtd.current
               (fun loc tok -> send tok) lexbuf 
	       (fun loc msg -> 
		   errors := (loc,msg) :: !errors;
		   set_progress (-1));
	     set_progress 100
	  end
       with (* document is not cached anymore ??? *)
	 Not_found -> Error.default#f
                         (I18n.sprintf "Document not in cache anymore")
    end
  in

  let source () =
    if !pending then
      Error.default#f (I18n.sprintf "Cannot view document source (pending)")
    else Source.view vgroup did redisplay errors
  in

  {widget = vgroup;
   display_token = (fun loc tok -> send tok);
   set_progress = set_progress;
   see_fragment = !current_formatter.see_frag;
   redisplay = redisplay;
   html_error =
     (fun loc msg -> errors := (loc,msg)::!errors; set_progress (-1));
   html_title = (fun () -> Textvariable.get titlev);
   html_source = source;
   load_images = (fun () -> !dispmach#imgmanager#load_images)
  }

(*
 * The builtin viewer for HTML
 *)

(* Displaying HTML *)
let display_html mediapars top vcontext dh =
  let url = dh.document_id.document_url in
  (* if the document is really far, we could have destroyed the window, but
     the viewer continuation of the retrieval would still be waiting to be
     executed *)
  if not (Winfo.exists top) then failwith "too late" else begin
    let htmlw = create top vcontext dh
    and red = ref 0                        (* bytes read *)
    and size =
      try Http_headers.contentlength dh.document_headers
      with Not_found -> 40000 (* duh *)
    in
    let abort = 
      let terminated = ref false in
      (fun () ->
	if not !terminated then begin
	    terminated := true;
	    vcontext.viewer_log "";
	    dclose true dh
	end)
    (* feed has special code for multiple reads *)
    and lexbuf = 
      let feed_read = 
        if !Version.japan then Japan.read (dh.document_feed.feed_read) 
        else dh.document_feed.feed_read 
      in
      Lexing.from_function 
	(fun buf n -> 
	   let r = feed_read buf 0 n in
	     red := !red + r;
	     htmlw.set_progress (if size = 0 then 100 else !red * 100 / size);
	     r)
    in
    let lexer = sgml_lexer !Dtd.current in
    (* Asynchronous parsing and display, token by token *)
    dh.document_feed.feed_schedule (fun () ->
	 try 
      	   let correct, tokens, loc = lexer lexbuf in
	   begin match correct with
	     Legal -> ()
	   | Illegal reason -> htmlw.html_error loc reason
	   end;
	   List.iter 
		(function token -> 
		   begin try
		     htmlw.display_token loc token
		   with
		     Invalid_Html s -> htmlw.html_error loc s
		   end;
		   if token = EOF then raise End_of_file)
	        tokens
	 with End_of_file ->
		htmlw.set_progress 100;
		abort ();
		htmlw.see_fragment dh.document_fragment
           (* this should not happen in Lexhtml was debugged *)
	   | Html_Lexing (s,n) -> 
	       htmlw.html_error (Html.Loc(n,n+1)) s
	   | Unix_error(_,_,_) -> abort()
           | e ->
             Log.f (sprintf "FATAL ERROR (htmlw) %s" (Stringexc.f e));
             abort());
    (* Handle on the widget for the navigator *)
    Some  {
        di_widget = htmlw.widget;
      	di_abort = 
      	  (fun () -> 
	      abort(); 
	      Img.ImageScheduler.stop dh.document_id;
	      Embed.EmbeddedScheduler.stop dh.document_id);
	di_destroy = 
          (fun () -> if Winfo.exists htmlw.widget then destroy htmlw.widget);
	di_fragment = htmlw.see_fragment;
	di_redisplay = htmlw.redisplay;
      	di_title = htmlw.html_title;
      	di_source = htmlw.html_source;
      	di_load_images = htmlw.load_images;
        di_last_used = !Low.global_time
        }
  end
