Re: segfault when reattaching a tree model to a tree view

(**************************************************************************)
(*    Lablgtk - Examples                                                  *)
(*                                                                        *)
(*    There is no specific licensing policy, but you may freely           *)
(*    take inspiration from the code, and copy parts of it in your        *)
(*    application.                                                        *)
(*                                                                        *)
(**************************************************************************)

(* Various experiments with GtkTreeModelSort and GtkTreeModelFilter *)

type date = {
    mon : int ;
    day : int ;
  }

let _ = GtkMain.Main.init ()

let format_date { mon = mon ; day = day } =
  let mon_str = match mon with
  | 1 -> "Jan" | 2 -> "Feb" | 3 -> "Mar" | 4 -> "Apr"
  | 5 -> "May" | 6 -> "Jun" | 7 -> "Jul" | 8 -> "Aou"
  | 9 -> "Sep" | 10 -> "Oct" | 11 -> "Nov" | 12 -> "Dec"
  | _ -> invalid_arg "bad month" in
  Printf.sprintf "% 2d %s" day mon_str

let data = [
  `HOME,    "home",   true,  { day = 29 ; mon = 02 } ;
  `JUMP_TO, "go",     true,  { day = 15 ; mon = 02 } ;
  `QUIT,    "quit",   false, { day = 27 ; mon = 01 } ;
  `STOP,    "stop",   true,  { day = 21 ; mon = 01 } ;
  `DELETE,  "delete", false, { day = 15 ; mon = 01 } ;
]



(* Sort function: sort according to string length ! *)
let sort_function column (model : #GTree.model) it_a it_b =
  let a = model#get ~row:it_a ~column in
  let b = model#get ~row:it_b ~column in
  compare (String.length a) (String.length b)


let print_flags name (m : #GTree.model) =
  Format.printf "%sflags: %s@." name
    (String.concat "; "
       (List.map
	  (function 
	    | `ITERS_PERSIST -> "persistent iterators"
	    | `LIST_ONLY     -> "list only")
	  m#flags))

type model = { model:GTree.model_sort;
	       model_filtered:GTree.model_filter;
	       store:GTree.list_store;
	       stock_id_col:GtkStock.id GTree.column;
	       str_col:string GTree.column;
	       vis_col:bool GTree.column;
	       date_col:date GTree.column; }

let make_model data =
  let cols = new GTree.column_list in
  let stock_id_col = cols#add GtkStock.conv in
  let str_col      = cols#add Gobject.Data.string in
  let vis_col      = cols#add Gobject.Data.boolean in
  let date_col     = cols#add Gobject.Data.caml in
  let l = GTree.list_store cols in
  print_flags "ListStore" l ;
  List.iter
    (fun (stock_id, str, vis, date) ->
      let row = l#append () in
      l#set ~row ~column:stock_id_col stock_id ;
      l#set ~row ~column:str_col str ;
      l#set ~row ~column:vis_col vis ;
      l#set ~row ~column:date_col date)
    data ;
  let s = GTree.model_sort l in
  print_flags "TreeModelSort" s ;
  let f = GTree.model_filter s in
  print_flags "TreeModelFilter" f ;
  f#set_visible_column vis_col ;
  (* let s' = GTree.model_sort f in *)
  s#connect#sort_column_changed
    (fun () ->
      match s#get_sort_column_id with
      | None -> Format.printf "no sort_column@."
      | Some (id, `ASCENDING)  ->
	  Format.printf "sort_column = %d, ascending@." id
      | Some (id, `DESCENDING) ->
	  Format.printf "sort_column = %d, descending@." id) ;
  s#set_sort_func 0 (sort_function str_col);
  {model=s; model_filtered=f; store=l;
   stock_id_col=stock_id_col; str_col=str_col;
   vis_col=vis_col; date_col=date_col; }

let make_view store packing =
  let view_col =
    let col = GTree.view_column ~title:"Stock Icons" () in

    let str_renderer =
      GTree.cell_renderer_text [ `FAMILY "monospace" ; `XALIGN 1. ] in
    col#pack str_renderer ;
    col#add_attribute str_renderer "text" store.str_col ;

    let pb_renderer = GTree.cell_renderer_pixbuf [ `STOCK_SIZE `BUTTON ] in
    col#pack pb_renderer ;
    col#add_attribute pb_renderer "stock_id" store.stock_id_col ;

    col#set_sort_column_id 0 ;
    col in

  let view_date_col =
    let col = GTree.view_column ~title:"Date" () in
    let str_renderer = GTree.cell_renderer_text [ `XALIGN 0.5 ] in
    col#pack str_renderer ;
    col#set_cell_data_func str_renderer
      (fun model row ->
	let date = model#get ~row ~column:store.date_col in
	str_renderer#set_properties [ `TEXT (format_date date) ]) ;
    col in

  let b =
    GButton.check_button ~label:"_Filter data" ~use_mnemonic:true ~packing () in

  let view_toggle_col =
    let col = GTree.view_column ~title:"Active" () in
    let toggle = GTree.cell_renderer_toggle [`ACTIVATABLE true] in
    col#pack toggle ;
    col#add_attribute toggle "active" store.vis_col;
    toggle#connect#toggled (fun p ->
      let l = store.store and column = store.vis_col in
      let p =
	if b#active then store.model_filtered#convert_path_to_child_path p
	else p in
      let row = l#get_iter (store.model#convert_path_to_child_path p) in
      l#set ~row ~column (not (l#get ~row ~column)));
    col in

  let scrollContainer = GBin.alignment ~packing () in
  scrollContainer#set_resize_mode `IMMEDIATE;
  let scroller =
    GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
      ~packing:scrollContainer#add ~width:150 ~height:100 () in
  scroller#set_shadow_type `ETCHED_IN;
  scroller#set_resize_mode `PARENT;

  let v = GTree.view ~model:store.model ~width:200 ~packing:scroller#add () 
  in
  v#append_column view_col ;
  v#append_column view_date_col ;
  v#append_column view_toggle_col ;
  b#connect#toggled
    (fun () -> 
      let new_model =
	if b#active
	then store.model_filtered#coerce
	else store.model#coerce in
      (* let (id, dir) =
	Gaux.default (-1, `ASCENDING) ~opt:current#get_sort_column_id in
      new_model#set_sort_column_id id dir ; *)

      v#set_model (Some new_model) ) ;
  v

let inspect_data_1 column (model : GTree.model) =
  Format.printf "@[<v 2>Traverse with iters:" ;
  begin match model#get_iter_first with
  | None -> Format.printf "@ empty model"
  | Some row ->
      let cont = ref true in
      while !cont do
	let data = model#get ~row ~column in
	Format.printf "@ %s" data ;
	cont := model#iter_next row
      done 
  end ;
  Format.printf "@]@."

let inspect_data_2 column (model : GTree.model) =
  Format.printf "@[<v 2>Traverse with #foreach:" ;
  model#foreach
    (fun _ row ->
      let data = model#get ~row ~column in
      Format.printf "@ %s" data ;
      false) ;
  Format.printf "@]@."

	
let main =
  let w = GWindow.window ~title:"GtkListStore test" () in
  w#connect#destroy GMain.quit ;

  let box = GPack.vbox ~packing:w#add () in

  let m = make_model data in
  let v = make_view m box#add in
  
  begin
    let b = GButton.button ~label:"Dump data" ~packing:box#pack () in
    b#connect#clicked
      (fun () ->
	let model = m.model#coerce in
	begin try
          ignore v#model;
	  v#set_model None;
	  inspect_data_1 m.str_col model ;
	  v#set_model (Some model);
	with _ -> ()
	end;
	inspect_data_2 m.str_col model)
  end ;

  w#show () ;
  GMain.main ()