(* Preferences *)
open Tk
open Mstring
open Fontprefs

let preffile = ref None

(* Generic report *)
let pref_error msg =
   Frx_dialog.f Widget.default_toplevel (gensym "error")
	  (I18n.sprintf "MMM Preference Error") 
	  msg
	  (Predefined "") 0 [I18n.sprintf "Ok"];
   ()

(* We badly need existential quantification here *)
type pref_type =
   Bool of bool ref
 | String of string ref
 | Int of int ref
 | Float of float ref
 | AbstractType of (Textvariable.textVariable -> unit) * 
      	       	 (Textvariable.textVariable -> unit)
                 (* init, set *)

type pref = {
  packed_widget : Widget.widget;
  pref_variable : Textvariable.textVariable;
  pref_type : pref_type;
  pref_name : string (* shall not contain : *)
}

(* Init the display from the references *)
let init_pref {pref_type = typ; pref_variable = v} = match typ with
   Bool r -> Textvariable.set v (if !r then "1" else "0")
 | String r -> Textvariable.set v !r
 | Int r ->  Textvariable.set v (string_of_int !r)
 | Float r ->  Textvariable.set v (string_of_float !r)
 | AbstractType(i,_) -> i v

(* Affect the references according to the variables *)
let set_pref {pref_type = typ; pref_variable = v} = match typ with
   Bool r -> r := Textvariable.get v = "1"
 | String r -> r := Textvariable.get v
 | Int r ->
     let s = Textvariable.get v in
      begin try r := int_of_string s
      with Failure "int_of_string" ->
      	     pref_error (I18n.sprintf "Not an integer: %s" s)
      end
 | Float r ->
     let s = Textvariable.get v in
      begin try r := float_of_string s
      with Failure "float_of_string" ->
      	     pref_error (I18n.sprintf "Not a float: %s" s)
      end
 | AbstractType(_,s) -> s v

(* Loads and sets the pref from a table *)
let load_pref table pref =
  try 
    let prefdata = Hashtbl.find table pref.pref_name in
      Textvariable.set pref.pref_variable prefdata;
      set_pref pref
  with
    Not_found -> ()

(* Save the pref from a table *)
let save_pref table pref =
  Hashtbl.add table pref.pref_name (Textvariable.get pref.pref_variable)

(* The basic preference types *)
let bool_pref name r top = 
  let v = Textvariable.create_temporary top in
  (* The frame is just to avoid expanding *)
  let f = Frame.create top [] in
  let w = Checkbutton.create f [Text name; Variable v] in
   pack [w][Side Side_Left; Anchor W; Fill Fill_X];
  {pref_type = Bool r;
   pref_variable = v;
   packed_widget = f;
   pref_name = name}

let int_pref name r top = 
  let v = Textvariable.create_temporary top in
  let f,e = Frx_entry.new_labelm_entry top name v in
  {pref_type = Int r;
   pref_variable = v;
   packed_widget = f;
   pref_name = name}

let float_pref name r top = 
  let v = Textvariable.create_temporary top in
  let f,e = Frx_entry.new_labelm_entry top name v in
  {pref_type = Float r;
   pref_variable = v;
   packed_widget = f;
   pref_name = name}

let string_pref name r top = 
  let v = Textvariable.create_temporary top in
  let f,e = Frx_entry.new_labelm_entry top name v in
  {pref_type = String r;
   pref_variable = v;
   packed_widget = f;
   pref_name = name}

let option_pref name i s p top =
  let v = Textvariable.create_temporary top in
  let f = Frame.create top [] in
  let l = Label.create f [Text name]
  and o,_ = Optionmenu.create f v p in
    pack [l;o][Side Side_Left];
    {pref_type = AbstractType(i,s);
     pref_variable = v;
     packed_widget = f;
     pref_name = name}

let abstract_pref name i s top =
  let v = Textvariable.create_temporary top in
  let f,e = Frx_entry.new_labelm_entry top name v in
  {pref_type = AbstractType(i,s);
   pref_variable = v;
   packed_widget = f;
   pref_name = name}

let abstract_bool_pref name i s top =
  let v = Textvariable.create_temporary top in
  (* The frame is just to avoid expanding *)
  let f = Frame.create top [] in
  let w = Checkbutton.create f [Text name; Variable v] in
   pack [w][Side Side_Left; Anchor W; Fill Fill_X];
  {pref_type = AbstractType(i,s);
   pref_variable = v;
   packed_widget = f;
   pref_name = name}

(* Some "abstract types" *)
let font_pref title name top = 
  let v = Textvariable.create_temporary top in
  let f,e = Frx_entry.new_labelm_entry top title v in
  let i v = 
     try Textvariable.set v (attrs2fontspec (Styles.get_font name))
     with Failure s -> pref_error s
  and s v = 
     try Styles.set_font name (fontspec2attrs (Textvariable.get v))
     with Failure s -> pref_error s in

    Entry.configure e [TextWidth 80];
    {pref_type = AbstractType(i,s);
     pref_variable = v;
     packed_widget = f;
     pref_name = title}

let image_loading_i v =
  Textvariable.set v 
     (match !Imgload.mode with
       Imgload.DuringDoc -> "During document loading"
     | Imgload.AfterDocAuto -> "After document, automatic"
     | Imgload.AfterDocManual -> "After document, manual")
and image_loading_s s =
  Imgload.mode :=
    match Textvariable.get s with
       "During document loading" -> Imgload.DuringDoc
     | "After document, automatic" -> Imgload.AfterDocAuto
     | "After document, manual" -> Imgload.AfterDocManual
     | _ -> Imgload.AfterDocManual
and image_loading_p =
  ["After document, manual"; 
   "After document, automatic"; 
   "During document loading"]

let dtd_i v =
  Textvariable.set v (Dtd.name !Dtd.current)
and dtd_s v =
  Dtd.current := 
    try
      Dtd.get (Textvariable.get v)
    with
      Not_found -> Dtd.dtd32
and dtd_p = Dtd.names()

(* Loading and saving from files *)    
(* Returns a table *)
let load_file f =
  try 
   let ic = open_in f in
   let table = Hashtbl.create 37 in
   try while true do
   let l = input_line ic in
   let pos = first_char_pos ':' l in
     let prefname = String.sub l 0 pos
     and prefdata = 
      	 if pos + 1 = String.length l then ""
	 else String.sub l (pos + 1) (String.length l - pos - 1) in
       Hashtbl.add table prefname prefdata
     done;
     table
   with
     End_of_file -> close_in ic; table
   | Not_found -> 
      close_in ic; failwith (I18n.sprintf "Bad preference file")
  with
    Sys_error _ ->
       failwith (I18n.sprintf "Can't open preference file: %s" f)

let save_file table f =
  try
    let oc = open_out f in
    Hashtbl.iter
      (fun name data ->
      	 output_string oc name; output_char oc ':'; output_string oc data;
      	 output_char oc '\n')
       table;
    close_out oc
  with
    Sys_error _ ->
      pref_error (I18n.sprintf "Can't open preference file: %s" f)


(* Builds a family of preferences *)
type pref_family =
  {family_widget: Widget.widget;
   family_init : unit -> unit;
   family_save : (string, string) Hashtbl.t -> unit;
   family_load : (string, string) Hashtbl.t -> unit
  }

let family top title preff =
  let f = Frame.create top [Relief Sunken; BorderWidth (Pixels 1)] in
  let prefs = List.map (fun p -> p f) preff in
  let init _ = List.iter init_pref prefs
  and load t = List.iter (load_pref t) prefs
  and save t = List.iter (save_pref t) prefs in
  init();
  let t = Label.create f [Text title]
  and fb = Frame.create f [] in
  let useb = Button.create_named fb "use"
    [Text (I18n.sprintf "Use"); 
     Command (fun () -> List.iter set_pref prefs)]
  and resetb = Button.create_named fb "reset"
    [Text (I18n.sprintf "Reset"); 
     Command (fun () -> 
      	       match !preffile with 
      	       	 None -> ()
      	       | Some f -> load (load_file f))]
  and dismissb = Button.create_named fb "dismiss"
    [Text (I18n.sprintf "Dismiss"); 
     Command (fun () -> init(); Wm.withdraw (Winfo.toplevel top))]
  in
  pack [useb;resetb;dismissb][Side Side_Left; Expand true];

  pack [t][];
  pack (List.map (fun p -> p.packed_widget) prefs) 
       [Fill Fill_X; Expand true; Anchor W];
  pack [fb][Fill Fill_X];
  {family_widget = f; family_init = init;
   family_load = load; family_save = save}

let network top = 
  family top (I18n.sprintf "Protocols") [
    string_pref "Proxy host" Http.proxy;
    int_pref "Proxy port" Http.proxy_port;
    bool_pref "Always Use Proxy" Http.always_proxy;
    bool_pref "HTTP Send Referer" Http.send_referer;
    string_pref "User Agent" Http.user_agent;
    int_pref "Timeout on headers (seconds)" Http.timeout;
    int_pref "Password lifetime (minutes)" Auth.lifetime;
    string_pref "Password save file" Auth.auth_file;
    string_pref "Local binaries path" File.binary_prefix
    ]

let internal top =
  family top (I18n.sprintf "Internal settings and debugging") [
    bool_pref "CamlTk Debug" Protocol.debug;
    bool_pref "General trace" Log.debug_mode;
    bool_pref "Cache debug" Cache.debug;
    bool_pref "Widget Cache debug" Gcache.debug;
    bool_pref "HTML Lexical errors" Lexhtml.verbose;
    bool_pref  "HTML Display log" Html_disp.verbose;
    bool_pref "Table debug" Table.debug;
    bool_pref "Text fit debug" Frx_fit.debug;
    bool_pref "Scheduler" Scheduler.debug;
    bool_pref "Image loading" Img.ImageData.verbose;
    bool_pref "HTTP Requests" Http.verbose
    ]

let html top = 
  family top (I18n.sprintf "HTML parsing and display") [
    option_pref "DTD" dtd_i dtd_s dtd_p;
    bool_pref "Strict HTML lexing" Lexhtml.strict;
    bool_pref "Attempt tables" Html_disp.attempt_tables;
    bool_pref "Attempt smooth scroll" Textw_fo.pscrolling;
    abstract_pref "Background color"
      (fun v -> Textvariable.set v !Textw_fo.html_bg)
      (fun v ->
	 let color = Textvariable.get v in
	    Textw_fo.html_bg := color;
 	    (* transparent GIF hack, for the initial images *)
	    Protocol.tkEval 
	    [|Protocol.TkToken "set";
	      Protocol.TkToken "TRANSPARENT_GIF_COLOR";
	      Protocol.TkToken color |];
            (* set the resource for each possible class of embedded windows *)
	    Resource.add "*Html*Text.background" color WidgetDefault;
            Resource.add "*Html*Message.background" color WidgetDefault;
            Resource.add "*Html*Label.background" color WidgetDefault;
            Resource.add "*Html*Listbox.background" color WidgetDefault;
            Resource.add "*Html*Button.background" color WidgetDefault;
            Resource.add "*Html*Entry.background" color WidgetDefault;
            Resource.add "*Html*Menubutton.background" color WidgetDefault;
            Resource.add "*Plain*Text.background" color WidgetDefault
	    );
    bool_pref "Follow document colors" Textw_fo.usecolors; 
    font_pref "Default font" "default";
    font_pref "<H1> font" "header1";
    font_pref "<H2> font" "header2";
    font_pref "<H3> font" "header3";
    font_pref "<H4> font" "header4";
    font_pref "<H5> font" "header5";
    font_pref "<H6> font" "header6";
    font_pref "Bold"   "bold";
    font_pref "Italic" "italic";
    font_pref "Fixed" "verbatim"
    ]

let i18n top =
  family top (I18n.sprintf "Internationalization") [
    bool_pref "Japanese mode" Version.japan
    ]

let images top =
  family top (I18n.sprintf "Images") [
    bool_pref "No images at all" Imgload.no_images;
    option_pref "Image loading" 
      	image_loading_i image_loading_s image_loading_p;
    int_pref "Max image connections" Img.ImageScheduler.maxactive;
    float_pref "Gamma correction" Img.ImageData.gamma;
    string_pref "JPEG converter"  Img.ImageData.jpeg_converter
    ]
    

let cache top =
  family top (I18n.sprintf "Cache settings") [
    int_pref "Max number of documents"  Cache.max_documents;
    int_pref "Delete how much when full" Cache.cleann;
    bool_pref "Keep only history" Cache.history_mode;
    int_pref "Max cached widgets per window" Gcache.max_keep
    ]

let progs top =
  family top (I18n.sprintf "External programs") [
    string_pref "Mailto program" Mailto.mailer;
    string_pref "Hotlist program" Hotlist.program
    ]

let misc top =
  family top (I18n.sprintf "Misc. settings") [
    bool_pref "Use balloon helps" Balloon.flag;
    bool_pref "Use GIF animation" Img.gif_anim_load;
    bool_pref "Automatic GIF animation display" Imgload.gif_anim_auto
    ]

let applets top =
  family top (I18n.sprintf "Applets") [
    abstract_bool_pref "Active" Appview.pref_init Appview.pref_set;
    bool_pref "Paranoid" Dload.paranoid
    ]


let inited = ref None

(* This is the startup *)
let init defaultpref =
  let top = Toplevel.create_named Widget.default_toplevel "prefs" 
      	       	  [Class "MMMPrefs"] in
   Wm.title_set top (I18n.sprintf "MMM Preferences");
   Wm.withdraw top;
   inited := Some top;
   (* this should be executed before the internal "all" binding *)
  bind top [[], Destroy] 
   (BindSet ([Ev_Widget],
      (fun ei -> if ei.ev_Widget = top then inited := None)));

  let mbar = Frame.create_named top "menubar" [] in

  let fnetwork = network top
  and finternal = internal top
  and fhtml = html top
  and fprogs = progs top
  and fcache = cache top
  and fi18n = i18n top
  and fimages = images top
  and fapplets = applets top
  and fmisc = misc top
  in

  let families = 
      [fnetwork;finternal;fhtml;fi18n;fprogs;fcache;fimages;fapplets;fmisc] in
  
  let current = ref fnetwork in
  let set_current f =
    Pack.forget [!current.family_widget];
    f.family_init();
    pack [f.family_widget] [Fill Fill_Both; Expand true];
    current := f in

  let preffilev = Textvariable.create_temporary top in
  let load () =
    Fileselect.f (I18n.sprintf "Load a preference file")
      (function [] -> ()
              | [s] -> 
	          Textvariable.set preffilev s; 
                  begin 
                    try
	              let t = load_file s in
	              List.iter (fun f -> f.family_load t) families
	            with Failure s -> pref_error s
		  end  
              | l -> raise (Failure "multiple selection"))
      (Filename.concat (Filename.dirname (Textvariable.get preffilev))
      	"*")
      (Filename.basename (Textvariable.get preffilev))
      false
      false

  and save () =
    Fileselect.f (I18n.sprintf "Save preferences to file")
      (function [] -> ()
              | [s] ->
	          Textvariable.set preffilev s;
  		  begin
                    try
  		    let t = Hashtbl.create 37 in 
  		      List.iter (fun f -> f.family_save t) families;
  		      save_file t s
  		    with Failure s -> pref_error s
                  end
              | l -> raise (Failure "multiple selection"))
      (Filename.concat (Filename.dirname (Textvariable.get preffilev))
      	"*")
      (Filename.basename (Textvariable.get preffilev))
      false
      false
   in

  let file = 
      Menubutton.create_named mbar "file"
      	 [Text (I18n.sprintf "File"); UnderlinedChar 0]
  and section = 
      Menubutton.create_named mbar "section" 
      	 [Text (I18n.sprintf "Section"); UnderlinedChar 0] 
  in

    pack [file;section][Side Side_Left];

  let mfile = Menu.create_named file "menu" [] in
    Menu.add_command mfile 
      	[Label (I18n.sprintf "Load"); Command load; UnderlinedChar 0];
    Menu.add_command mfile 
      	[Label (I18n.sprintf "Save"); Command save; UnderlinedChar 0];
    Menu.add_command mfile 
        [Label (I18n.sprintf "Dismiss");
      	 Command (fun () -> Wm.withdraw top); UnderlinedChar 0];
    Menubutton.configure file [Menu mfile];

  let sectionv = Textvariable.create_temporary top in
  let msection = Menu.create_named section "menu" [] in
    Menu.add_radiobutton msection 
      [Label (I18n.sprintf "Protocols"); 
       Command (fun () -> set_current fnetwork); Variable sectionv];
    Menu.add_radiobutton msection 
      [Label (I18n.sprintf "HTML parsing and display"); 
       Command (fun () -> set_current fhtml); Variable sectionv];
    Menu.add_radiobutton msection 
      [Label (I18n.sprintf "Internationalization"); 
       Command (fun () -> set_current fi18n); Variable sectionv];
    Menu.add_radiobutton msection 
      [Label (I18n.sprintf "Images"); 
       Command (fun () -> set_current fimages); Variable sectionv];
    Menu.add_radiobutton msection 
      [Label (I18n.sprintf "External programs"); 
       Command (fun () -> set_current fprogs); Variable sectionv];
    Menu.add_radiobutton msection 
      [Label (I18n.sprintf "Cache settings");
       Command (fun () -> set_current fcache); Variable sectionv];
    Menu.add_radiobutton msection 
      [Label (I18n.sprintf "Applets"); 
       Command (fun () -> set_current fapplets); Variable sectionv];
    Menu.add_radiobutton msection 
      [Label (I18n.sprintf "Misc. settings"); 
       Command (fun () -> set_current fmisc); Variable sectionv];
    Menu.add_radiobutton msection 
      [Label (I18n.sprintf "Internal settings and debugging"); 
       Command (fun () -> set_current finternal); Variable sectionv];
    Menubutton.configure section [Menu msection];
  Textvariable.set sectionv (I18n.sprintf "Protocols");
  pack [mbar][Side Side_Top; Anchor W; Fill Fill_X];

  preffile := defaultpref;
  begin match defaultpref with
    None -> 
     Textvariable.set preffilev 
        (Filename.concat (Filename.concat (Sys.getenv "HOME") ".mmm") "prefs")
  | Some f -> 
     Textvariable.set preffilev f;
     try
      let t = load_file f in
	List.iter (fun f -> f.family_load t) families
     with Failure s -> pref_error s
  end;
  set_current fnetwork

let rec f () =
  match !inited with
    Some w -> Wm.deiconify w
  | None -> (* we have been destroyed ! *)
      init None; f()