Re: tooltip on treeview cell

(* ocamlc -o tooltips -I +lablgtk2 lablgtk.cma gtkInit.cmo tooltips.ml && ./tooltips *)

class contact
  ~(name: string)
  () =
  object (self)
	method name = name
  end
class account
  ~(name: string)
  ~(contacts: contact list)
  () =
  object (self)
	method name = name
	method contacts = contacts
  end

let model () =
	let cols = new GTree.column_list in
	let column = cols#add Gobject.Data.caml in
	let model = GTree.tree_store cols in
	List.iter begin fun account ->
		let row = model#append () in
		model#set ~row ~column (`Account account);
		List.iter begin fun contact ->
			let row = model#append ~parent: row () in
			model#set ~row ~column (`Contact contact)
		  end account#contacts
	  end
	  [ new account ()
		  ~name: "Fernand Naudin"
		  ~contacts:
			  [ new contact () ~name: "Maître Folace"
			  ; new contact () ~name: "Jean" ]
	  ; new account ()
		  ~name: "Raoul Volfoni"
		  ~contacts: [ new contact () ~name: "Paul Volfoni" ]
	  ];
	(model, column)

class tooltip
  ?(show_delay = 1000)
  ?(hide_delay = 2000)
  () =
  object (self)
	val window = GWindow.window ()
	  ~title: "gtk-tooltips"
	  ~resizable: true
	  ~kind: `POPUP
	  ~border_width: 1
	  ~show: true
	method window = window
	val style = new GObj.style (GtkData.Style.create ())
	
	val show_delay = show_delay
	val hide_delay = hide_delay
	val mutable is_hidden = true
	method is_hidden = is_hidden
	method show =
		is_hidden <- false;
		window#show ()
	method hide =
		is_hidden <- true;
		window#misc#hide ()
	val mutable timeout = None
	(* the timeout to hide/show the window *)
	
	method stop_timeout
	  ?(on_some = (ignore: unit -> unit))
	  () =
		match timeout with
		| Some id ->
			GMain.Timeout.remove id;
			timeout <- None;
			on_some ()
		| None -> ()
	method start_timeout
	  ?(on_some = (ignore: unit -> unit))
	  ?(on_expire = (fun () -> self#hide))
	  ?(ms = hide_delay)
	  () =
		self#stop_timeout () ~on_some;
		timeout <- Some (GMain.Timeout.add ~ms
		  ~callback: (fun _ ->
			timeout <- None;
			on_expire ();
			false))
	
	initializer
		window#misc#set_app_paintable true;
		(* style *)
		let state_type = `NORMAL in
		style#set_bg [state_type, `BLACK];
		window#misc#set_style style;
		(* callbacks *)
		let _ = window#connect#destroy ~callback: GMain.quit in
		let _ = window#event#connect#enter_notify
		  ~callback: (fun ev -> self#stop_timeout (); true) in
		let _ = window#event#connect#leave_notify
		  ~callback: (fun ev -> self#start_timeout (); true) in
		()
	
	method set
	  (content: GPack.box) =
		let module Private = struct exception Exn end in
		try let child = try window#child with Gpointer.Null -> raise Private.Exn in
			if child#get_oid <> content#get_oid
			then (child#destroy (); window#add content#coerce);
		with Private.Exn -> window#add content#coerce
  end

class type ['cell] treeview_tooltip_content =
  object
	method box : GPack.box
	  (* the box to be packed within the tooltip window *)
	method has_changed : 'cell -> 'cell -> bool
	  (* to avoid useless refresh *)
	method set :
	  path: Gtk.tree_path ->
	    (* the path to the cell *)
	  connection: (GObj.event_ops -> unit) ->
	    (* to stop the timeout hidding the tooltip *)
	  'cell -> unit
	    (* to update the tooltip content *)
  end

class ['cell] treeview_tooltip
  ~(content: 'cell treeview_tooltip_content)
    (* the object used to put the tooltip content up to date *)
  ~(column: 'cell GTree.column)
    (* the column holding the tooltip data used to get the tooltip content *)
  ~(treeview: GTree.view)
    (* the treeview related to the tooltip *)
  ~(get_position: tooltip_rect: Gtk.rectangle -> GdkEvent.Motion.t -> int * int)
    (* coordinates where the tooltip shall be *)
  ?(hide_delay = 2000)
  () =
  object (self)
	inherit tooltip () ~hide_delay as super_tooltip
	
	val mutable last_cell = None
	(* the content of the last cell for which a tooltip has been drawn *)
	
	initializer
		(* callback that try to refresh the tooltip
		 * when the mouse is over the treeview *)
		let _ = treeview#event#connect#motion_notify
		  ~callback: (fun ev ->
			self#start_timeout ()
			  ~ms: show_delay
			  ~on_some: (fun _ -> last_cell <- None)
			  ~on_expire: begin fun _ ->
				match treeview#get_path_at_pos
				  ~x: (int_of_float (GdkEvent.Motion.x ev))
				  ~y: (int_of_float (GdkEvent.Motion.y ev)) with
				| Some (path, view_col, _, _) ->
					self#stop_timeout ();
					let row = treeview#model#get_iter path in
					let cell = treeview#model#get ~row ~column in
					(match last_cell with
					| Some old_cell when not (content#has_changed old_cell cell) -> ()
					| _ ->
						last_cell <- Some cell;
						content#set cell ~path
						  ~connection: begin fun event ->
							let _ = event#connect#enter_notify
							  ~callback: (fun ev -> self#stop_timeout (); true) in
							let _ = event#connect#leave_notify
							  ~callback: (fun ev -> self#start_timeout (); true) in
							let _ = event#connect#button_press
							  ~callback: (fun ev -> self#hide; true) in () end;
						self#set content#box;
						let {Gtk.x=tx; y=ty; width=tw; height=th} as tooltip_rect =
						  GtkBase.Widget.allocation self#window#as_widget in
						let x, y = get_position ~tooltip_rect ev in
						let sw, sh = Gdk.Screen.width (), Gdk.Screen.height () in
						let x = (* set x inside the screen *)
						  if x < 0 then 0
						  else if x + tw > sw
						  then sw - tw
						  else x in
						let y = (* set y inside the screen *)
						  if y < 0 then 0
						  else if y + th > sh
						  then sh - th
						  else y in
						self#show;
						self#window#move ~x ~y)
				| _ -> self#start_timeout () end;
			true) in
		let _ = treeview#event#connect#leave_notify
		  ~callback: (fun ev -> self#start_timeout (); true) in
		()
  end

let main () =
	let (model, column) = model () in
	let window = GWindow.window ()
	  ~title: "TreeView"
	  ~show: true in
	let vbox = GPack.vbox ()
	  ~border_width: 0
	  ~spacing: 8
	  ~packing: window#add in
	let sw = GBin.scrolled_window ()
	  ~shadow_type: `ETCHED_IN
	  ~hpolicy: `NEVER
	  ~vpolicy: `AUTOMATIC
	  ~packing: vbox#add in
	let _ = window#connect#destroy
	  ~callback: GMain.quit in
	
	let treeview = GTree.view ()
	  ~model ~packing: sw#add in
	
	let col = GTree.view_column ()
	  ~title: "Column title" in
	let renderer_name = GTree.cell_renderer_text [] in
	col#set_sizing `FIXED;
	col#set_fixed_width 50;
	col#pack renderer_name;
	col#set_cell_data_func renderer_name
	  begin fun model row ->
		match model#get ~row ~column with
		| `Account account ->
			let text = account#name in
			renderer_name#set_properties
			  [ `TEXT text
			  ; `WEIGHT `BOLD ]
		| `Contact contact ->
			renderer_name#set_properties
			  [ `TEXT contact#name
			  ; `WEIGHT `NORMAL ] end;
	ignore (treeview#append_column col);
	
	let tooltip_tree_view =
		new treeview_tooltip ()
		  ~column ~treeview: treeview
		  ~get_position: begin fun ~tooltip_rect ev ->
			let cursor_x = int_of_float (GdkEvent.Motion.x_root ev) in
			let cursor_y = int_of_float (GdkEvent.Motion.y_root ev) in
			cursor_x + 16, cursor_y + 16 end
		  ~content: begin object (self: 'self)
			constraint 'self = 'cell #treeview_tooltip_content
			val vbox = GPack.vbox () ~border_width: 0 ~spacing: 0
			val style = new GObj.style (GtkData.Style.create ())
			initializer
				let state_type = `NORMAL in
				style#set_bg [state_type, `NAME "yellow"];
				style#set_fg [state_type, `BLACK];
			method set ~path ~connection cell =
				List.iter (fun child -> child#destroy ()) vbox#children;
				let event_box = GBin.event_box () ~packing: vbox#add in
				connection event_box#event;
				event_box#misc#set_style style;
				let path_string = GtkTree.TreePath.to_string path in
				let name =
					(* XXX: be careful to do a match on the good thing: no static type checking *)
					match cell with
					| `Account o -> o#name
					| `Contact o -> o#name in
				let markup = "path=<b>" ^ path_string ^ "</b> name=<b>" ^ name ^ "</b>" in
				let _ = GMisc.label () ~markup
				  ~packing: event_box#add in ()
			method box = vbox
			method has_changed old_cell cell =
				old_cell != cell
		  end end in
	let _ = window#event#connect#configure
	  ~callback: (fun _ -> tooltip_tree_view#hide; false) in
	()
;;
main ();;

GMain.Main.main ()