(* $Id$ *)

open Gaux
open Gtk
open Tags
open GtkBase

module GammaCurve = struct
  let cast w : gamma_curve obj = Object.try_cast w "GtkGammaCurve"
  external create : unit -> gamma_curve obj = "ml_gtk_gamma_curve_new"
  external get_gamma : [>`gamma] obj -> float = "ml_gtk_gamma_curve_get_gamma"
end

module ColorSelection = struct
  let cast w : color_selection obj = Object.try_cast w "GtkColorSelection"
  external create : unit -> color_selection obj = "ml_gtk_color_selection_new"
  external create_dialog : string -> color_selection_dialog obj
      = "ml_gtk_color_selection_dialog_new"
  external set_update_policy : [>`colorsel] obj -> update_type -> unit
      = "ml_gtk_color_selection_set_update_policy"
  external set_opacity : [>`colorsel] obj -> bool -> unit
      = "ml_gtk_color_selection_set_opacity"
  let set ?update_policy ?opacity w =
    may update_policy ~f:(set_update_policy w);
    may opacity ~f:(set_opacity w)
  external set_color :
      [>`colorsel] obj ->
      red:float -> green:float -> blue:float -> ?opacity:float -> unit
      = "ml_gtk_color_selection_set_color"
  external get_color : [>`colorsel] obj -> color
      = "ml_gtk_color_selection_get_color"

  external ok_button : [>`colorseldialog] obj -> button obj =
    "ml_gtk_color_selection_dialog_ok_button"
  external cancel_button : [>`colorseldialog] obj -> button obj =
    "ml_gtk_color_selection_dialog_cancel_button"
  external help_button : [>`colorseldialog] obj -> button obj =
    "ml_gtk_color_selection_dialog_help_button"
  external colorsel : [>`colorseldialog] obj -> color_selection obj =
    "ml_gtk_color_selection_dialog_colorsel"
  module Signals = struct
    open GtkSignal
    let color_changed : ([>`colorsel],_) t =
      { name = "color_changed"; marshaller = marshal_unit }
  end
end

module Statusbar = struct
  let cast w : statusbar obj = Object.try_cast w "GtkStatusbar"
  external create : unit -> statusbar obj = "ml_gtk_statusbar_new"
  external get_context : [>`statusbar] obj -> string -> statusbar_context
      = "ml_gtk_statusbar_get_context_id"
  external push :
      [>`statusbar] obj ->
      statusbar_context -> text:string -> statusbar_message
      = "ml_gtk_statusbar_push"
  external pop : [>`statusbar] obj -> statusbar_context ->  unit
      = "ml_gtk_statusbar_pop"
  external remove :
      [>`statusbar] obj -> statusbar_context -> statusbar_message -> unit
      = "ml_gtk_statusbar_remove"
  module Signals = struct
    open GtkSignal
    let text_pushed : ([>`statusbar],_) t =
      let marshal f _ = function
        | GtkArgv.INT ctx :: GtkArgv.STRING s :: _ ->
	    f (Obj.magic ctx : statusbar_context) s
        | _ -> invalid_arg "GtkMisc.Statusbar.Signals.marshal_text"
      in
      { name = "text_pushed"; marshaller = marshal }
  end
end

module Calendar = struct
  let cast w : calendar obj = Object.try_cast w "GtkCalendar"
  external create : unit -> calendar obj = "ml_gtk_calendar_new"
  external select_month : [>`calendar] obj -> month:int -> year:int -> unit
      = "ml_gtk_calendar_select_month"
  external select_day : [>`calendar] obj -> int -> unit
      = "ml_gtk_calendar_select_day"
  external mark_day : [>`calendar] obj -> int -> unit
      = "ml_gtk_calendar_mark_day"
  external unmark_day : [>`calendar] obj -> int -> unit
      = "ml_gtk_calendar_unmark_day"
  external clear_marks : [>`calendar] obj -> unit
      = "ml_gtk_calendar_clear_marks"
  external display_options :
      [>`calendar] obj -> Tags.calendar_display_options list -> unit
      = "ml_gtk_calendar_display_options"
  external get_date : [>`calendar] obj -> int * int * int
      = "ml_gtk_calendar_get_date"   (* year * month * day *)
  external freeze : [>`calendar] obj -> unit
      = "ml_gtk_calendar_freeze"
  external thaw : [>`calendar] obj -> unit
      = "ml_gtk_calendar_thaw"
  module Signals = struct
    open GtkSignal
    let month_changed : ([>`calendar],_) t =
      { name = "month_changed"; marshaller = marshal_unit }
    let day_selected : ([>`calendar],_) t =
      { name = "day_selected"; marshaller = marshal_unit }
    let day_selected_double_click : ([>`calendar],_) t =
      { name = "day_selected_double_click"; marshaller = marshal_unit }
    let prev_month : ([>`calendar],_) t =
      { name = "prev_month"; marshaller = marshal_unit }
    let next_month : ([>`calendar],_) t =
      { name = "next_month"; marshaller = marshal_unit }
    let prev_year : ([>`calendar],_) t =
      { name = "prev_year"; marshaller = marshal_unit }
    let next_year : ([>`calendar],_) t =
      { name = "next_year"; marshaller = marshal_unit }
  end
end

module DrawingArea = struct
  let cast w : drawing_area obj = Object.try_cast w "GtkDrawingArea"
  external create : unit -> drawing_area obj = "ml_gtk_drawing_area_new"
  external size : [>`drawing] obj -> width:int -> height:int -> unit
      = "ml_gtk_drawing_area_size"
end

(* Does not seem very useful ...
module Curve = struct
  type t = [widget drawing curve] obj
  let cast w : t = Object.try_cast w "GtkCurve"
  external create : unit -> t = "ml_gtk_curve_new"
  external reset : [>`curve] obj -> unit = "ml_gtk_curve_reset"
  external set_gamma : [>`curve] obj -> float -> unit
      = "ml_gtk_curve_set_gamma"
  external set_range :
      [>`curve] obj -> min_x:float -> max_x:float ->
      min_y:float -> max_y:float -> unit
      = "ml_gtk_curve_set_gamma"
end
*)

module Misc = struct
  let cast w : misc obj = Object.try_cast w "GtkMisc"
  external coerce : [>`misc] obj -> misc obj = "%identity"
  external set_alignment : [>`misc] obj -> x:float -> y:float -> unit
      = "ml_gtk_misc_set_alignment"
  external set_padding : [>`misc] obj -> x:int -> y:int -> unit
      = "ml_gtk_misc_set_padding"
  external get_xalign : [>`misc] obj -> float = "ml_gtk_misc_get_xalign"
  external get_yalign : [>`misc] obj -> float = "ml_gtk_misc_get_yalign"
  external get_xpad : [>`misc] obj -> int = "ml_gtk_misc_get_xpad"
  external get_ypad : [>`misc] obj -> int = "ml_gtk_misc_get_ypad"
  let set_alignment w ?x ?y () =
    set_alignment w ~x:(may_default get_xalign w ~opt:x)
      ~y:(may_default get_yalign w ~opt:y)
  let set_padding w ?x ?y () =
    set_padding w ~x:(may_default get_xpad w ~opt:x)
      ~y:(may_default get_ypad w ~opt:y)
  let set ?xalign ?yalign ?xpad ?ypad ?(width = -2) ?(height = -2) w =
    if xalign <> None || yalign <> None then
      set_alignment w ?x:xalign ?y:yalign ();
    if xpad <> None || ypad <> None then
      set_padding w ?x:xpad ?y:ypad ();
    if width <> -2 || height <> -2 then Widget.set_usize w ~width ~height
end

module Arrow = struct
  let cast w : arrow obj = Object.try_cast w "GtkArrow"
  external create : kind:arrow_type -> shadow:shadow_type -> arrow obj
      = "ml_gtk_arrow_new"
  external set : [>`arrow] obj -> kind:arrow_type -> shadow:shadow_type -> unit
      = "ml_gtk_arrow_set"
end

module Image = struct
  let cast w : image obj = Object.try_cast w "GtkImage"
  external create : Gdk.image -> ?mask:Gdk.bitmap -> image obj
      = "ml_gtk_image_new"
  let create ?mask img = create img ?mask
  external set : [>`image] obj -> Gdk.image -> ?mask:Gdk.bitmap -> unit
      = "ml_gtk_image_set"
end

module Label = struct
  let cast w : label obj = Object.try_cast w "GtkLabel"
  external coerce : [>`label] obj -> label obj = "%identity"
  external create : string -> label obj = "ml_gtk_label_new"
  external set_text : [>`label] obj -> string -> unit = "ml_gtk_label_set_text"
  external set_justify : [>`label] obj -> justification -> unit
      = "ml_gtk_label_set_justify"
  external set_pattern : [>`label] obj -> string -> unit
      = "ml_gtk_label_set_pattern"
  external set_line_wrap : [>`label] obj -> bool -> unit
      = "ml_gtk_label_set_line_wrap"
  let set ?text ?justify ?line_wrap ?pattern w =
    may ~f:(set_text w) text;
    may ~f:(set_justify w) justify;
    may ~f:(set_line_wrap w) line_wrap;
    may ~f:(set_pattern w) pattern
  external get_text : [>`label] obj -> string = "ml_gtk_label_get_label"
end

module TipsQuery = struct
  let cast w : tips_query obj = Object.try_cast w "GtkTipsQuery"
  external create : unit -> tips_query obj = "ml_gtk_tips_query_new"
  external start : [>`tipsquery] obj -> unit = "ml_gtk_tips_query_start_query"
  external stop : [>`tipsquery] obj -> unit = "ml_gtk_tips_query_stop_query"
  external set_caller : [>`tipsquery] obj -> [>`widget] obj -> unit
      = "ml_gtk_tips_query_set_caller"
  external set_labels :
      [>`tipsquery] obj -> inactive:string -> no_tip:string -> unit
      = "ml_gtk_tips_query_set_labels"
  external set_emit_always : [>`tipsquery] obj -> bool -> unit
      = "ml_gtk_tips_query_set_emit_always"
  external get_caller : [>`tipsquery] obj -> widget obj
      = "ml_gtk_tips_query_get_caller"
  external get_label_inactive : [>`tipsquery] obj -> string
      = "ml_gtk_tips_query_get_label_inactive"
  external get_label_no_tip : [>`tipsquery] obj -> string
      = "ml_gtk_tips_query_get_label_no_tip"
  external get_emit_always : [>`tipsquery] obj -> bool
      = "ml_gtk_tips_query_get_emit_always"
  let set_labels ?inactive ?no_tip w =
    set_labels w
      ~inactive:(may_default get_label_inactive w ~opt:inactive)
      ~no_tip:(may_default get_label_no_tip w ~opt:no_tip)
  let set ?caller ?emit_always ?label_inactive ?label_no_tip w =
    may caller ~f:(set_caller w);
    may emit_always ~f:(set_emit_always w);
    if label_inactive <> None || label_no_tip <> None then
      set_labels w ?inactive:label_inactive ?no_tip:label_no_tip
  module Signals = struct
    open GtkArgv
    open GtkSignal
    let start_query : ([>`tipsquery],_) t =
      { name = "start_query"; marshaller = marshal_unit }
    let stop_query : ([>`tipsquery],_) t =
      { name = "stop_query"; marshaller = marshal_unit }
    let widget_entered :
	([>`tipsquery],
	 widget obj option ->
	 text:string option -> privat:string option -> unit) t =
      let marshal f _ = function
        | OBJECT opt :: STRING text :: STRING privat :: _ ->
	    f (may_map ~f:Widget.cast opt) ~text ~privat
        | _ -> invalid_arg "GtkMisc.TipsQuery.Signals.marshal_entered"
      in
      { name = "widget_entered"; marshaller = marshal }
    let widget_selected :
	([>`tipsquery],
	 widget obj option ->
	 text:string option ->
	 privat:string option -> GdkEvent.Button.t option -> bool) t =
      let marshal f argv = function
        | OBJECT obj :: STRING text :: STRING privat :: POINTER p :: _ ->
	    let stop = 
	      f (may_map ~f:Widget.cast obj) ~text ~privat
	        (may_map ~f:GdkEvent.unsafe_copy p)
            in set_result argv (`BOOL stop)
        | _ -> invalid_arg "GtkMisc.TipsQuery.Signals.marshal_selected"
      in
      { name = "widget_selected"; marshaller = marshal }
  end
end

module Pixmap = struct
  let cast w : pixmap obj = Object.try_cast w "GtkPixmap"
  external create : Gdk.pixmap -> ?mask:Gdk.bitmap -> pixmap obj
      = "ml_gtk_pixmap_new"
  let create ?mask img = create img ?mask
  external set :
      [>`pixmap] obj -> ?pixmap:Gdk.pixmap -> ?mask:Gdk.bitmap -> unit
      = "ml_gtk_pixmap_set"
  external pixmap : [>`pixmap] obj -> Gdk.pixmap = "ml_GtkPixmap_pixmap"
  external mask : [>`pixmap] obj -> Gdk.bitmap = "ml_GtkPixmap_mask"
end

module Separator = struct
  let cast w : separator obj = Object.try_cast w "GtkSeparator"
  external hseparator_new : unit -> separator obj = "ml_gtk_hseparator_new"
  external vseparator_new : unit -> separator obj = "ml_gtk_vseparator_new"
  let create (dir : Tags.orientation) =
    if dir = `HORIZONTAL then hseparator_new () else vseparator_new ()
end

module FontSelection = struct
  type null_terminated
  let null_terminated arg : null_terminated =
    match arg with None -> Obj.magic Gpointer.raw_null
    | Some l ->
	let len = List.length l in
	let arr = Array.create (len + 1) "" in
	let rec loop i = function
	    [] -> arr.(i) <- Obj.magic Gpointer.raw_null
	  | s::l -> arr.(i) <- s; loop (i+1) l
	in loop 0 l;
	Obj.magic (arr : string array)
  let cast w : font_selection obj =
    Object.try_cast w "GtkFontSelection"
  external create : unit -> font_selection obj
      = "ml_gtk_font_selection_new"
  external get_font : [>`fontsel] obj -> Gdk.font
      = "ml_gtk_font_selection_get_font"
  let get_font w =
    try Some (get_font w) with Gpointer.Null -> None
  external get_font_name : [>`fontsel] obj -> string
      = "ml_gtk_font_selection_get_font_name"
  let get_font_name w =
    try Some (get_font_name w) with Gpointer.Null -> None
  external set_font_name : [>`fontsel] obj -> string -> unit
      = "ml_gtk_font_selection_set_font_name"
  external set_filter :
    [>`fontsel] obj -> font_filter_type -> font_type list ->
    null_terminated -> null_terminated -> null_terminated ->
    null_terminated -> null_terminated -> null_terminated -> unit
    = "ml_gtk_font_selection_set_filter_bc"
      "ml_gtk_font_selection_set_filter"
  let set_filter w ?kind:(tl=[`ALL]) ?foundry
      ?weight ?slant ?setwidth ?spacing ?charset filter =
    set_filter w filter tl (null_terminated foundry)
      (null_terminated weight) (null_terminated slant)
      (null_terminated setwidth) (null_terminated spacing)
      (null_terminated charset)
  external get_preview_text : [>`fontsel] obj -> string
      = "ml_gtk_font_selection_get_preview_text"
  external set_preview_text : [>`fontsel] obj -> string -> unit
      = "ml_gtk_font_selection_set_preview_text"
end