(* Gui *)
(* $Id: gui.ml,v 1.25 2004/10/26 09:44:54 berke Exp $ *)
(* vim:set fileencoding=utf-8: *)

(* TODO: default pane size adjustment
 * TODO: implement transitive closure-like higher-order operators
 * TODO: track dependencies in variables ; update' em
 * TODO: load/save variables
 * TODO: generic function caching (isn't this what lazy does ? not really -- or is it ?)
 * TODO: multiple tasks at once ; installing a package shouldn't freeze flare
*)

open GMain;;
open Gdk;;
open Debug;;
open Util;;

module Prefs =
  struct
    let show_empty_fields = ref true
  end
;;

(*** Parse arguments... *)
let () =
  Arg.parse
    Opt.specs
    (fun f -> Printf.eprintf "Argument %S ignored.\n" f; flush stderr)
    (Sys.argv.(0) ^ " [options]")
;;
(* ***)

let ign f x = ignore (f x)

(*** Make *)
module Make(Dpkg : Dpkg.DB) =
  struct
    module Ara = Ara.Make(Dpkg)
    (*** Utf8... *)
    let from_utf8 msg =
      try
        Glib.Convert.convert msg ~to_codeset:"ISO-8859-1" ~from_codeset:"UTF-8"
      with
      | x ->
          debug 0 (sf "Error trying to convert string %S from UTF-8: %s" msg (Printexc.to_string x));
          raise x
    let to_utf8 msg =
      try
        Glib.Convert.convert msg ~to_codeset:"UTF-8" ~from_codeset:"ISO-8859-1"
      with
      | x ->
          debug 0 (sf "Error trying to convert string %S to UTF-8: %s" msg (Printexc.to_string x));
          raise x
    ;;
    (* ***)
    (*** Flash... *)
    let flash_context : GMisc.statusbar_context option ref = ref None
    let flash_mutex = Mutex.create ()
    let flash msg =
      match !flash_context with
      | None -> debug 0 (sf "flash: %s" msg)
      | Some ctx ->
          Mutex.lock flash_mutex;
          ctx#flash ~delay:3000 (to_utf8 msg);
          Mutex.unlock flash_mutex
    ;;
    (* Flash ***)
    let catch_utf8 x f =
      try
        f x
      with
      | Glib.Convert.Error(_,_) -> flash "Error: Invalid, non-ISO-8859-1 characters."
    ;;
    let db_mutex = Mutex.create ();;
    let database = new Publication.magazine;;

    (*** follow_window_size *)
    let follow_window_size ~window ~name =
      let esig = new GObj.event_signals window#as_widget in
      ignore (esig#configure ~callback:(fun cfg ->
        let (w,h) = (GdkEvent.Configure.width cfg, GdkEvent.Configure.height cfg) in
        Config.current#set_int ("xara.windows."^name^".width") w;
        Config.current#set_int ("xara.windows."^name^".height") h;
        false))
    ;;
    (* ***)

    (*** database_paths *)
    let database_paths ?(config = Config.current) () =
      let k = "xara.database.paths" in
      let module CF = Configfile in
      CF.to_list
        (CF.to_pair CF.to_string CF.to_string)
        ~k
        (config#get
          ?default:(Some(CF.List[CF.Tuple[CF.String "/var/lib/dpkg/";
                                     CF.String "^available$"]]))
          k)
    ;;
    (* ***)
    (*** compute_interactive_command *)
    let compute_interactive_command cmd =
      let runi = Config.current#get_string "xara.commands.run_interactive_command" in
      Util.substitute_variables ["COMMAND",cmd] runi
    ;;
    (* ***)
    (*** sections_of_database *)
    let sections_of_database db =
      let module SS = Set.Make(String) in
      let j = Dpkg.field_of_string db "section" in
      let m = Dpkg.get_count db in
      let rec loop s i =
        if i = m then
          s
        else
          loop (let u = Dpkg.get_field db i j in if u <> "" then SS.add u s else s) (i + 1)
      in
      SS.elements (loop SS.empty 0)
    ;;
    (* ***)
    (*** GDK & GTK2 initialisation... *)
    let visual = Gdk.Rgb.get_visual ();;
    let () =
      Gdk.Rgb.init ();
      GtkBase.Widget.set_default_visual visual;
      GtkBase.Widget.set_default_colormap (Gdk.Rgb.get_cmap ())
    ;;
    let hbox p = GPack.hbox ~border_width:5 ~spacing:5 ~packing:p ();;
    let vbox p = GPack.vbox ~border_width:5 ~spacing:5 ~packing:p ();;
    let window = GWindow.window
      ~title:(sf "Xara %s" Version.version)
      ~allow_grow:true
      ~allow_shrink:true
      ~width:(Config.current#get_int ~default:800 "xara.windows.main.width")
      ~height:(Config.current#get_int ~default:600 "xara.windows.main.height")
      ()
    ;;

    (* ***)
    (*** Busy *)
    let busy_count = ref 0;;
    let sleep_cursor = Gdk.Cursor.create `WATCH;;
    let normal_cursor = Gdk.Cursor.create `LEFT_PTR;;
    let i_am_busy () =
      incr busy_count;
      Gdk.Window.set_cursor window#misc#window sleep_cursor; Gdk.X.flush ();;
    let i_am_ready () =
      decr busy_count;
      if !busy_count = 0 then
        Gdk.Window.set_cursor window#misc#window normal_cursor; Gdk.X.flush ();;
    (* Busy ***)
    (*** Computation *)

    module Computation =
      struct
        exception Busy;;

        let job = ref None;;
        let job_mutex = Mutex.create ();;
        let job_condition = Condition.create ();;

        let thread () = 
          Mutex.lock job_mutex;
          while true do
            begin
              match !job with
              | Some(j,job_name) ->
                  flash (sf "Working: %s" job_name);
                  i_am_busy ();
                  begin
                    try
                      j ();
                      job := None;
                      flash (sf "Done: %s" job_name)
                    with
                    | x ->
                        job := None;
                        flash (sf "Job %s failed: %s" job_name (Printexc.to_string x))
                  end;
                  i_am_ready ()
              | None -> ()
            end;
            Condition.wait job_condition job_mutex
          done
        ;;

        let launch_job j =
          if Mutex.try_lock job_mutex then
            begin
              let x =
                match !job with
                | None -> job := Some j; false
                | Some _ -> true
              in
              Mutex.unlock job_mutex;
              if x then raise Busy
              else Condition.signal job_condition
            end
          else
            raise Busy
        ;;

        let init () =
          let ct = Thread.create thread () in
          ()
        ;;

      end
      ;;
    (* Computation ***)
    (*** Bookmarks... *)
    class virtual ['a] bookmarks =
      object(self)
        val mutable marks : 'a list = []
        val mutable callback : ('a list -> unit) option = None
        method virtual path : string
        method virtual load : unit
        method virtual save : unit
        method set_callback f = callback <- f
        method as_list = marks
        method call_callback f =
          let marks' = marks in
          Util.wind f () (fun _ ->
            if marks <> marks' then
              match callback with
              | None -> ()
              | Some f -> f marks
            else
              ())
            ()
        method clear = self#call_callback (fun () -> List.iter (fun w -> self#remove w) marks)
        method remove w = self#call_callback (fun () -> marks <- List.filter ((<>) w) marks)
        method add w =
          self#call_callback (fun () ->
            if not (List.mem w marks) then
              marks <- w::marks
            else
              ())
        method is_present w = List.mem w marks
      end
    ;;
    class package_marks =
      object(self)
        inherit [string * string] bookmarks as super
        method path = Config.current#path "bookmarks" 
        method load =
          let fn = self#path in
          debug 10 (sf "Loading bookmarks from %S" fn);
          try
            let ic = open_in fn in
            self#clear;
            let sb = Scanf.Scanning.from_file fn in
            try
              while true do
                Scanf.bscanf sb " mark %S %S" (fun pn pv -> self#add (pn,pv))
              done;
              assert false
            with
            | x ->
                close_in ic;
                flash (to_utf8 (sf "Error reading bookmarks from file %S: %s"
                                 fn (Printexc.to_string x)))
          with
          | x -> flash (to_utf8 (sf "Could not load bookmarks from file %S: %s"
                                 fn (Printexc.to_string x)))
        method save =
          let fn = self#path in
          debug 10 (sf "Saving bookmarks to %S" fn);
          try
            Config.current#ensure_directory_presence;
            let oc = open_out fn in
            List.iter (fun (pn,pv) -> Printf.fprintf oc "mark %S %S\n" pn pv) marks;
            close_out oc
          with
          | x -> flash (to_utf8 (sf "Could not save bookmarks to file %S: %s"
                                 fn (Printexc.to_string x)))
      end
    ;;
    let bookmarks = new package_marks;;
    (* bookmarks ***)
    (*** Menu... *)
    let v0 = GPack.vbox ~spacing:5 ~border_width:5 ~packing:window#add ();;
    let menu_bar = GMenu.menu_bar ~packing:v0#pack ();;
    (* ***)
    (*** package_display *)
    class package_display ~packing (*~(menu : GMenu.menu GMenu.factory)*) () =
      let frame = GBin.frame ~packing () in
      let label = GMisc.label ~use_underline:true ~text:"_Package" () in
      let _ = frame#set_label_widget (Some(label#coerce)) in
      let pane = GPack.paned `HORIZONTAL ~packing:frame#add ~border_width:5 () in
      (* let _ = pane#set_position 400 in *)
      let vbox_contents = GPack.vbox ~packing:(pane#pack1 ~shrink:false) () in
      let hbox_contents = GPack.hbox ~packing:vbox_contents#pack () in
      let package_label =
        GMisc.label
          ~text:"No package yet"
          ~packing:(hbox_contents#pack ~from:`START)
          ()
      in
      let show_empty_fields = GButton.check_button
                                ~use_mnemonic:true
                                ~label:"Show empt_y fields"
                                ~active:(Config.current#get_bool
                                           ~default:false
                                           "xara.windows.main.show_empty_fields")
                                ~packing:(hbox_contents#pack ~from:`END) ()
      in
      let pf = new Dpkg.paragraph_folder in
      let sw_contents =
        GBin.scrolled_window
          ~packing:vbox_contents#add
          ~hpolicy:`AUTOMATIC
          ~vpolicy:`AUTOMATIC
          ()
      in
      let contents = GList.clist
                 ~width:200
                 ~height:100
                 ~titles:["Field";"Contents"]
                 ~auto_sort:false
                 ~packing:sw_contents#add
                 ~titles_active:false
                 (* ~vadjustment:v_scrollbar#adjustment
                 ~hadjustment:h_scrollbar#adjustment *)
                 (* ~reorderable:true *)
                 ()
      in
      let _ = label#set_mnemonic_widget (Some(contents#coerce)) in
      let frame_vbox = GPack.vbox ~packing:(pane#pack2 ~shrink:false) () in
      let detail_vbox = GPack.vbox ~spacing:15 ~packing:frame_vbox#pack () in
      let detail_hbox = GPack.hbox ~spacing:15 ~packing:detail_vbox#pack () in
      let detail_label =
        GMisc.label ~justify:`CENTER
                    ~text:"No field to display." ~packing:detail_hbox#pack () in
      let search_hbox = GPack.hbox ~spacing:5 ~packing:detail_vbox#add () in
      let search_label = GMisc.label ~use_underline:true ~text:"_Search:" ~packing:search_hbox#pack () in
      let search_entry = GEdit.entry ~packing:search_hbox#add () in
      let _ = search_label#set_mnemonic_widget (Some(search_entry#coerce)) in
      let search_bwd_button =
        GButton.button ~use_mnemonic:true ~stock:`GO_BACK ~packing:search_hbox#pack ()
      and search_fwd_button =
        GButton.button ~use_mnemonic:true ~stock:`GO_FORWARD ~packing:search_hbox#pack ()
      and search_check_case = GButton.check_button
                             ~use_mnemonic:true
                             ~label:"_Case sensitive"
                             ~active:(Config.current#get_bool
                                        ~default:false
                                        "xara.windows.main.case_sensitive")
                             ~packing:search_hbox#pack ()
      in
      let frame_detail =
        GBin.scrolled_window
          ~hpolicy:`AUTOMATIC
          ~vpolicy:`AUTOMATIC
          ~packing:frame_vbox#add
        ()
      in

      let tags_highlight = GText.tag ~name:"highlight" () in
      let detail_tag_table = GText.tag_table () in
      let _ = detail_tag_table#add tags_highlight#as_tag in
      let _ = tags_highlight#set_property (`BACKGROUND "yellow") in
      let detail_buffer = GText.buffer ~tag_table:detail_tag_table () in

      let detail = GText.view
                     ~height:100
                     ~width:150
                     ~wrap_mode:`WORD
                     ~packing:frame_detail#add
                     ~editable:false
                     ~cursor_visible:false
                     ~border_width:1
                     ~buffer:detail_buffer
                     ()
      in
      object(self)
        val mutable package = [||]
        val mutable field_text = ""
        val mutable detail_field = 0
        val mutable current_db = None
        val mutable search_pattern = ""
        val mutable search_case = false
        val mutable search_regexp = Str.regexp ""
        val mutable search_position = (0,0)
        val export_dir = ref (Sys.getcwd ())
        initializer
          ignore (search_check_case#connect#clicked (fun _ ->
            Config.current#set_bool
              "xara.windows.main.case_insensitive"
              search_check_case#active));
          ignore (contents#connect#select_row
            ~callback:(fun ~row ~column ~event ->
                self#with_db (fun db ->
                  detail_field <- Dpkg.field_of_string db (contents#get_row_data row));
                self#redisplay_detail));
          ignore (contents#event#connect#button_press ~callback:(fun ev ->
            let button = GdkEvent.Button.button ev in
            if button = 3 then 
              begin
                GToolbox.popup_menu
                  ~entries:self#popup_entries ~button ~time:(GdkEvent.Button.time ev);
                true
              end
            else false));
          ignore (search_entry#connect#activate ~callback:(fun _ -> self#search ()));
          ignore (search_fwd_button#connect#clicked ~callback:(fun _ -> self#search ()));
          ignore (search_bwd_button#connect#clicked ~callback:(fun _ -> self#search ~backwards:true ()));
          ignore (show_empty_fields#connect#clicked ~callback:(fun _ ->
            Config.current#set_bool "xara.windows.main.show_empty_fields"
              show_empty_fields#active;
            self#repopulate));
          search_entry#misc#set_sensitive false;
          contents#set_column ~auto_resize:true 0;
          contents#set_column ~auto_resize:true 1;
        (*** bookmark *)
        method popup_entries =
            [`I("Bookmark",               (fun () -> self#bookmark));
             `I("Unbookmark",             (fun () -> self#unbookmark));
             `S;
             `I("APT install",            (fun () -> self#install));
             `I("APT remove",             (fun () -> self#remove));
             `S;
             `I("Print",                  (fun () -> self#print));
             `I("Export (as plain text)", (fun () -> self#export))]
        method clear_bookmarks =
          match bookmarks#as_list with
          | [] -> flash "No bookmarks to clear."
          | l ->
              let n = List.length l in
              let md =
                GWindow.message_dialog
                  ~message:(if n = 1 then "Shall I clear your bookmark ?"
                            else sf "Shall I clear all your %d bookmarks ?" n)
                  ~message_type:`QUESTION
                  ~buttons:GWindow.Buttons.yes_no
                  ~title:(sf "Clear bookmarks ?")
                  ~modal:true
                  ~show:true
                  ()
              in
              let answer = md#run () in
              md#destroy ();
              if answer = `YES then
                bookmarks#clear
              else
                ()
        method bookmark =
          self#with_db (fun db ->
            let pn = package.(Dpkg.package_field db)
            and pv = package.(Dpkg.version_field db)
            in
            if bookmarks#is_present (pn,pv) then
              flash (to_utf8 (sf "There is already a bookmark for %S (%S)" pn pv))
            else
              begin
                bookmarks#add (pn,pv);
                flash (to_utf8 (sf "Added bookmark for %S (%S)" pn pv))
              end)
        method unbookmark =
          self#with_db (fun db ->
            let pn = package.(Dpkg.package_field db)
            and pv = package.(Dpkg.version_field db)
            in
            if bookmarks#is_present (pn,pv) then
              begin
                bookmarks#remove (pn,pv);
                flash (to_utf8 (sf "Removed bookmark for %S (%S)" pn pv))
              end
            else
              flash (to_utf8 (sf "There is no bookmark for %S (%S)" pn pv)))
        (* ***)
        (*** search *)
        method contents_widget = contents
        method search ?(backwards=false) () =
          catch_utf8 () (fun () ->
          let u = from_utf8 (search_entry#text) in
          if search_case <> search_check_case#active or u <> search_pattern then
            begin
              try
                search_case <- search_check_case#active;
                search_regexp <- if search_case then Str.regexp u else Str.regexp_case_fold u;
                search_pattern <- u;
                search_position <- (0,0)
              with
              | x -> flash (sf "Bad search pattern: %s" (Printexc.to_string x))
            end;
          if u = search_pattern && Array.length package > detail_field then
            begin
              try
                let w = field_text in
                let (spi,spj) = search_position in
                if backwards then
                  ignore (Str.search_backward
                            search_regexp
                            w
                            (max 0 (spi - 1)))
                else
                  ignore (Str.search_forward
                            search_regexp
                            w
                            spj);
                let i = Str.match_beginning ()
                and j = Str.match_end ()
                in
                search_position <- (i,j);
                let b = detail_buffer in
                b#set_text "";
                let m = String.length w in
                if i > 0 then b#insert ~tags:[] (to_utf8 (String.sub w 0 i));
                b#insert ~tags:[tags_highlight] (to_utf8 (String.sub w i ((min (m - 1) j) - i)));
                if j < m then b#insert ~tags:[] (to_utf8 (String.sub w j (m - j)));
                ignore (detail#scroll_to_iter (b#get_iter (`OFFSET i)));
                detail#scroll_to_mark
                  ~use_align:true ~yalign:0.5 (`MARK(b#create_mark (b#get_iter_at_char i)))
              with
              | Not_found -> flash "Pattern not found."
            end
          else
            ())
        (* ***)
        (*** with_db, redisplay_detail, repopulate, set_package *)
        method with_db f =
          match current_db with
          | None -> flash "No package selected yet !"
          | Some db -> f db
        method redisplay_detail =
          search_entry#misc#set_sensitive true;
          search_position <- (0,0);
          self#with_db (fun db ->
          let c =
            let u = package.(detail_field) in
            try
              ignore (String.index u '\n');
              pf#reset;
              pf#add_string u;
              pf#get
            with
            | Not_found ->
              u
          in
          field_text <- c;
          detail_label#set_text (Dpkg.display_string_of_field db detail_field);
          detail#buffer#set_text (to_utf8 field_text))
        method repopulate =
          contents#freeze ();
          contents#clear ();
          self#with_db (fun db ->
            for i = 0 to Array.length package - 1 do
              let k = Dpkg.display_string_of_field db i in
              let v = package.(i) in
              if show_empty_fields#active or v <> "" then
                let r =
                  contents#append
                    [to_utf8 k;
                     to_utf8 (first_line v)]
                in
                contents#set_row_data r (Dpkg.string_of_field db i)
              else
                ()
            done);
          contents#thaw ()
        method set_package db i =
          if current_db = None then detail_field <- Dpkg.field_of_string db "description";
          current_db <- Some db;
          let pn = Dpkg.name_of db i
          and pv = Dpkg.version_of db i
          in
          package <- Dpkg.get_package db i;
          package_label#set_text (to_utf8 (sf "%s version %s" pn pv));
          self#repopulate;
          self#redisplay_detail
        (* ***)
        (*** output_package_info *)
        method output_package_info db package oc =
          let pf = new Dpkg.paragraph_folder in
          let first_fields = ["package";"version"]
          and last_fields = ["description"]
          in
          let stuff =
            List.iter (fun fd ->
              try
                let fi = Dpkg.field_of_string db fd in
                if package.(fi) <> "" then
                  begin
                    pf#reset;
                    pf#add_string package.(fi);
                    Printf.fprintf oc "%s: %s\n" (Dpkg.display_name_of_field db fi) pf#get
                  end
              with
              | Not_found -> ())
          in
          stuff first_fields;
          let excluded_fields = first_fields@last_fields in
          for fi = 0 to Array.length package - 1 do
            let fd = Dpkg.string_of_field db fi in
            if not (List.mem fd excluded_fields) && package.(fi) <> "" then
              begin
                Printf.fprintf oc "%s: %s\n" (Dpkg.display_name_of_field db fi) package.(fi)
              end
          done;
          stuff last_fields;
        (* ***)
        (*** export *)
        method export =
          self#with_db (fun db ->
            let pn = package.(Dpkg.package_field db)
            and pv = package.(Dpkg.version_field db)
            in
            match
              GToolbox.select_file
                ~title:(to_utf8 (sf "Export package info for %s (%s) as text file" pn pv))
                ~dir:export_dir
                ~filename:(sf "%s-%s.txt" pn pv)
                ()
            with
            | Some(fn) ->
                begin
                  try
                    let oc = open_out fn in
                    self#output_package_info db package oc;
                    close_out oc;
                    flash (to_utf8 (sf "Package info for %s (%s) exported to file %s"
                                    pn pv fn))
                  with
                  | x -> flash (to_utf8 (sf "Could not export package info into file %s: %s"
                           fn (Printexc.to_string x)))
                end
            | None -> ())
        (* ***)
        (*** print *)
        method print =
          self#with_db (fun db ->
            let pn = package.(Dpkg.package_field db)
            and pv = package.(Dpkg.version_field db)
            in
            try
              Computation.launch_job
               ((fun () ->
                 let cmd =
                   Util.substitute_variables
                     ["PACKAGE", pn; "VERSION", pv]
                     (Config.current#get_string "xara.commands.print")
                 in
                 let (ic,oc,ec) = Unix.open_process_full cmd (Unix.environment ()) in
                 self#output_package_info db package oc;
                 let ps = Unix.close_process_full (ic,oc,ec) in
                 GtkThread.async flash
                   (match ps with
                    | Unix.WEXITED(rc) ->
                      if rc = 0 then
                        sf "Printing of information on %S (%S) succeeded" pn pv
                      else
                        sf "Printing of information on %S (%S) failed with code %d" pn pv rc
                    | Unix.WSIGNALED(sg) ->
                      sf "Printing of information on %S (%S) failed with signal %d" pn pv sg
                    | Unix.WSTOPPED(sg) ->
                      sf "Printing of information on %S (%S) stopped by signal %d" pn pv sg)),
                 sf "Printing information on %S (%S)..." pn pv)
            with
            | Computation.Busy -> flash "Busy...")
        (* ***)
        (*** install, remove, install_or_remove *)
        method install = self#install_or_remove ~remove:false
        method remove = self#install_or_remove ~remove:true
        method install_or_remove ~remove =
          self#with_db (fun db ->
            let pn = package.(Dpkg.package_field db)
            and pv = package.(Dpkg.version_field db)
            in
            let cmd = Util.substitute_variables
              ["PACKAGE",pn; "VERSION",pv]
              (if remove then
                Config.current#get_string "xara.commands.remove"
              else
                Config.current#get_string "xara.commands.install")
            in
            let icmd = compute_interactive_command cmd in
            let md =
              GWindow.message_dialog
                ~message:(to_utf8 (sf "Are you sure you want to %s\n%S version %S ?\n\n\
                                       The following command will be launched:\n\n\
                                       %S"
                                      (if remove then "remove" else "install")
                                      pn pv
                                      icmd))
                ~message_type:`QUESTION
                ~buttons:GWindow.Buttons.yes_no
                ~title:(sf "Software %s" (if remove then "removal" else "installation"))
                ~modal:true
                ~show:true
                ()
            in
            let answer = md#run () in
            md#destroy ();
            if answer = `YES then
              begin
                try
                  Computation.launch_job
                   ((fun () ->
                     let rc = Sys.command icmd in
                     GtkThread.async flash
                       (if rc <> 0 then
                          (sf "%s of %S (%S) failed with code %d"
                            (if remove then "Removal" else "Installation")
                            pn pv rc)
                       else
                          (sf "%s of %S (%S) succeeded"
                            (if remove then "Removal" else "Installation")
                            pn pv))),
                    (sf "%s %S version %S"
                        (if remove then "Removing" else "Installing")
                        pn pv))
                with
                | Computation.Busy -> flash "Busy..."
              end)
      end;;
    (* ***)
    (* package_display ***)
    (*** results_display *)
    class results_display ~popup_entries ~packing () =
      let frame = GBin.frame ~packing () in
      let frame_label = GMisc.label ~use_underline:true ~text:"_Result" () in
      let _ = frame#set_label_widget (Some(frame_label#coerce)) in
      let frame_v = GPack.vbox ~packing:frame#add ~border_width:5 () in
      let h = GPack.hbox ~packing:frame_v#pack ~border_width:5 () in
      let label = GMisc.label ~text:"No result yet." ~packing:(h#pack ~from:`START) () in
      let check_coalesce = GButton.check_button
                             ~use_mnemonic:true
                             ~label:"_Newest only"
                             ~active:(Config.current#get_bool
                                        ~default:true
                                        "xara.windows.main.newest_only")
                             ~packing:(h#pack ~from:`END) ()
      in
      let frame_h =
        GBin.scrolled_window
          ~hpolicy:`AUTOMATIC
          ~vpolicy:`AUTOMATIC
          ~packing:frame_v#add
          ()
      in
      let contents = GList.clist
                 ~width:500
                 ~height:100
                 ~titles:["Name";"Version";"Description"]
                 ~packing:frame_h#add
                 ~titles_active:false
                 ()
      in
      let _ = frame_label#set_mnemonic_widget (Some(contents#coerce)) in
      let ( **> ) x y =
        if x = 0 then
          y ()
        else
          x
      in
      let sort db l =
        let a = Array.of_list l in
        Array.sort (fun i j ->
          ((compare (Dpkg.name_of db i) (Dpkg.name_of db j))
           **> (fun () -> compare (Dpkg.version_of db j) (Dpkg.version_of db i)))
           **> (fun () -> compare i j)) a;
        Array.to_list a
      in
      object(self)
        val mutable package_list = []
        val mutable coalesced_package_list = []
        val mutable current_db = None
        val mutable when_selected = fun _ _ -> ()
        initializer
          ignore (check_coalesce#connect#clicked (fun _ ->
            Config.current#set_bool "xara.windows.main.newest_only" check_coalesce#active;
            self#repopulate))
        method displayed_package_list =
          if check_coalesce#active then
            coalesced_package_list
          else
            package_list
        method set_when_selected f = when_selected <- f
        method with_db f =
          match current_db with
          | None -> ()
          | Some db -> f db
        initializer
          ignore (contents#connect#select_row ~callback:(fun ~row ~column ~event ->
            self#with_db (fun db ->
              let x = List.nth (self#displayed_package_list) row in
              when_selected db x;
              let name = Dpkg.name_of db x in
              flash (sf "Package %s selected." name))));
          ignore (contents#event#connect#button_press ~callback:(fun ev ->
            let button = GdkEvent.Button.button ev in
            if button = 3 then 
              begin
                GToolbox.popup_menu ~entries:popup_entries ~button ~time:(GdkEvent.Button.time ev);
                true
              end
            else false));
          List.iter (contents#set_column ~auto_resize:true) [0;1;2]
          
        method repopulate =
          contents#freeze ();
          i_am_busy ();
          contents#clear ();
          contents#set_column ~visibility:(not check_coalesce#active) 1;
          self#with_db (fun db ->
            let description_field = Dpkg.field_of_string db "description" in
            List.iter (fun i ->
                  ignore (contents#append
                    (List.map
                      (fun (f,l) -> to_utf8
                         (limit l (first_line (Dpkg.get_field db i f))))
                      [Dpkg.package_field db,32;
                       Dpkg.version_field db,32;
                       description_field,256])))
              self#displayed_package_list);
          contents#thaw ();
          i_am_ready ();
          let n = List.length package_list
          and n' = List.length coalesced_package_list
          in
          label#set_text (sf "Total %d package%s (and %d version%s)."
            n' (if n' = 1 then "" else "s")
            n (if n = 1 then "" else "s"))
        method set_package_list db pl =
          current_db <- Some db;
          package_list <- sort db pl;
          coalesced_package_list <- sort db (Ara.filter_old_versions db pl);
          self#repopulate
      end
    ;;
    (* results_display ***)
    (*** configure *)
    class configure config' () =
      let config = Configurator.duplicate config' in
      let cd =
        GWindow.window
          ~allow_grow:true
          ~allow_shrink:true
          ~width:(Config.current#get_int ~default:700 "xara.windows.config.width")
          ~height:(Config.current#get_int ~default:500 "xara.windows.config.height")
          ~title:"Configure Flare"
          ~modal:true
          ~show:false
          ()
      in
      let _ = follow_window_size ~window:cd ~name:"config" in
      let vb1 = GPack.vbox ~border_width:5 ~spacing:5 ~packing:cd#add () in

      (* search paths *)
      let f1 = GBin.frame ~label:"Database search _paths" ~packing:vb1#add () in
      let nb1 = GPack.notebook ~border_width:5 ~packing:f1#add () in
      let vb11 = GPack.vbox
        ~spacing:5
        ~packing:(ign (nb1#append_page ~tab_label:((GMisc.label ~text:"Edit" ())#coerce))) ()
      in
      let vb12 = GPack.vbox
        ~spacing:5 ~border_width:5 
        ~packing:(ign (nb1#append_page ~tab_label:((GMisc.label ~text:"Show" ())#coerce))) ()
      in
      let sw121 = GBin.scrolled_window
        ~hpolicy:`AUTOMATIC
        ~vpolicy:`AUTOMATIC
        ~packing:vb12#add
        ()
      in
      let hb121 = GPack.hbox ~spacing:5 ~packing:vb12#pack () in
      let files_label = GMisc.label
        ~text:"Press \"Slurp\" to see files."
        ~packing:hb121#pack ()
      in
      let button_slurp = GButton.button
        ~use_mnemonic:true
        ~label:"_Slurp"
        ~packing:(hb121#pack ~from:`END) ()
      in
      let files = GList.clist
                 ~titles:["Directory";"File"]
                 ~titles_active:false
                 ~packing:sw121#add
                 ()
      in
      let _ =
        files#set_column ~auto_resize:true 0;
        files#set_column ~auto_resize:true 1
      in
      let hb11 = GPack.hbox ~border_width:5 ~spacing:5 ~packing:vb11#add () in
      let sw111 = GBin.scrolled_window
        ~hpolicy:`AUTOMATIC
        ~vpolicy:`AUTOMATIC
        ~packing:hb11#add
        ()
      in
      let pth = GList.clist
                 ~titles:["Directory";"Filename regexp"]
                 ~titles_active:false
                 ~packing:sw111#add
                 ()
      in
      let _ =
        pth#set_column ~auto_resize:true 0;
        pth#set_column ~auto_resize:true 1
      in
      let hb112 = GPack.hbox ~border_width:5 ~spacing:5 ~packing:vb11#pack () in
      let edit_dir = GEdit.entry ~packing:hb112#add () in
      let edit_regex = GEdit.entry ~packing:hb112#add () in
      let button_change = GButton.button ~use_mnemonic:true ~label:"C_hange" ~packing:hb112#add () in
      let vb111 = GPack.vbox ~border_width:5 ~spacing:5 ~packing:hb11#pack () in
      let button_new = GButton.button ~use_mnemonic:true ~label:"_Add" ~packing:vb111#pack () in
      let button_delete = GButton.button ~use_mnemonic:true ~label:"_Remove" ~packing:vb111#pack () in
      (* commands *)
      let f2 = GBin.frame ~label:"Commands" ~packing:vb1#pack () in

      let tbl21 = GPack.table ~border_width:5 ~columns:2 ~packing:f2#add () in
      let tbl_row = ref 0 in
      let string_entry text =
        let lbl = GMisc.label ~text () in
        let ent = GEdit.entry () in
        tbl21#attach ~left:0 ~top:!tbl_row (lbl#coerce);
        tbl21#attach ~expand:`X ~left:1 ~top:!tbl_row (ent#coerce);
        incr tbl_row;
        ent
      in
      let string_entries =
        List.map (fun (x,y) -> (string_entry x, y))
            [ "Run interactive commands with:" ,"xara.commands.run_interactive_command";
              "Install:", "xara.commands.install";
              "Remove:" ,"xara.commands.remove";
              "Update:" ,"xara.commands.update";
              "Upgrade:" ,"xara.commands.upgrade";
              "Dist-upgrade:" ,"xara.commands.dist_upgrade";
              "Print:" ,"xara.commands.print" ]
      in
      (* buttons *)
      let hb3 = GPack.hbox ~border_width:5 ~spacing:5 ~packing:vb1#pack () in
      let button_apply = GButton.button ~use_mnemonic:true ~label:"_Use these" ~packing:hb3#add () in
      let button_save = GButton.button ~use_mnemonic:true ~label:"_Save" ~packing:hb3#add () in
      let button_restore = GButton.button ~use_mnemonic:true ~label:"Rest_ore" ~packing:hb3#add () in
      let button_defaults = GButton.button ~use_mnemonic:true ~label:"_Defaults" ~packing:hb3#add () in
      let button_cancel = GButton.button ~use_mnemonic:true ~label:"_Cancel" ~packing:hb3#add () in
      let st1 = GMisc.statusbar ~packing:vb1#pack () in
      let ctx = st1#new_context ~name:"Message" in
      object(self)
        val mutable current_row = None
        val mutable paths = database_paths ~config ()
        initializer
          ignore (button_new#connect#clicked
            (fun _ ->
              paths <- ("","")::paths;
              ignore (pth#insert ~row:0 ["";""]);
              pth#select 0 0));
          ignore (pth#connect#select_row ~callback:(fun ~row ~column ~event ->
            current_row <- Some row;
            let (x,y) = List.nth paths row in
            edit_dir#set_text (to_utf8 x);
            edit_regex#set_text (to_utf8 y)));
          ignore (button_change#connect#clicked (fun _ ->
            match current_row with
            | None -> ctx#flash "Don't know which row to change."
            | Some i ->
                catch_utf8 () (fun () ->
                let x = from_utf8 edit_dir#text
                and y = from_utf8 edit_regex#text
                in
                paths <- Util.list_change_nth paths i (x,y);
                self#repopulate)));
          ignore (button_delete#connect#clicked
            (fun _ ->
              match current_row with
              | None -> ctx#flash "Don't know which row to delete."
              | Some i ->
                  pth#remove ~row:i;
                  current_row <- None;
                  paths <- Util.list_remove_nth paths i));
          ignore (button_apply#connect#clicked
            (fun _ ->
              self#depopulate;
              config'#set_context (Configfile.duplicate_context config#context);
              cd#destroy ()));
          ignore (button_restore#connect#clicked
            (fun _ ->
              config#set_context (Configfile.duplicate_context config'#context);
              self#repopulate));
          ignore (button_defaults#connect#clicked
            (fun _ ->
              match config#load_defaults with
              | [] -> self#repopulate
              | ex ->
                  ctx#flash (to_utf8 (sf "Errors occured: %s"
                    (String.concat ","
                      (List.map (fun (fn,x) ->
                          sf "%S: %s" fn (Printexc.to_string x)) ex))))
            ));
          ignore (button_save#connect#clicked
            (fun _ ->
              self#depopulate;
              config'#set_context (Configfile.duplicate_context config#context);
              config'#save));
          ignore (button_cancel#connect#clicked (fun _ -> cd#destroy ()));
          ignore (button_slurp#connect#clicked (fun _ -> self#slurp));
          self#repopulate;
          cd#show ()
        method depopulate =
          List.iter
            (fun (x,y) -> config#set_string y (from_utf8 x#text))
            string_entries;
          let module CF = Configfile in
          config#set "xara.database.paths"
            (CF.List(List.map (fun (x,y) -> CF.Tuple[CF.String x;CF.String y]) paths))

        method slurp =
          files_label#set_text (to_utf8
            (try
              let fl = Dpkg.find_database_files paths in
              files#freeze ();
              files#clear ();
              List.iter (fun fn -> ignore (files#append
                [to_utf8 (Filename.dirname fn);
                 to_utf8 (Filename.basename fn)])) fl;
              files#thaw ();
              match List.length fl with
              | 0 -> "Warning: No files match the given patterns."
              | 1 -> "One database file."
              | n -> sf "Total %d files." n
            with
            | x -> sf "Error: %s" (Printexc.to_string x)))

        method repopulate =
          List.iter
            (fun (x,y) -> x#set_text (to_utf8 (config#get_string y)))
            string_entries;
          current_row <- None;
          pth#freeze ();
          pth#clear ();
          List.iter (fun (x,y) ->
            ignore (pth#append [to_utf8 x; to_utf8 y]))
            paths;
          pth#thaw ()
      end
    ;;
    (* ***)
    (*** apt_update *)
    let apt_update vr () =
      let update_cmd = compute_interactive_command (Config.current#get_string vr) in
      let md =
        GWindow.message_dialog
          ~message:(to_utf8 (sf "Okay to launch command\nthe following command ?\n\n%s" update_cmd))
          ~message_type:`QUESTION
          ~buttons:GWindow.Buttons.yes_no
          ~title:(sf "APT update")
          ~modal:true
          ~show:true
          ()
      in
      let answer = md#run () in
      md#destroy ();
      if answer = `YES then
        try
          Computation.launch_job
           ((fun () ->
             let rc = Sys.command update_cmd in
             GtkThread.async flash
               (if rc <> 0 then
                  (sf "APT update failed with code %d" rc)
               else
                  "APT update succeeded")),
            "APT update in progress...")
        with
        | Computation.Busy -> flash "Busy..."
    ;;
    (* ***)
    (*** syntax_help *)
    (* TODO: text search field for syntax help *)
    class syntax_help ~packing () =
      let f3 = GBin.scrolled_window
        ~hpolicy:`AUTOMATIC
        ~vpolicy:`AUTOMATIC
        ~packing
        ()
      in
      let t1 = GText.view
                   ~height:100
                   ~width:100
                   ~wrap_mode:`WORD
                   ~packing:f3#add
                   ~editable:false
                   ~cursor_visible:false
                   ~border_width:1
                   ()
      in
      object(self)
        initializer
          t1#buffer#set_text Help.syntax
      end
    ;;
    class help_window ?(on_close = ignore) () =
      let hw =
        GWindow.window
          ~title:(sf "Xara %s help" Version.version)
          ~modal:false
          ~show:false
          ~allow_grow:true
          ~allow_shrink:true
          ~width:(Config.current#get_int ~default:400 "xara.windows.help.width")
          ~height:(Config.current#get_int ~default:300 "xara.windows.help.height")
          ()
      in
      let _ = follow_window_size ~window:hw ~name:"help" in
      let _ = hw#connect#destroy ~callback:(fun () -> on_close ()) in
      let v = GPack.vbox ~border_width:5 ~spacing:5 ~packing:hw#add () in
      let sh = new syntax_help ~packing:v#add () in
      let h = GPack.hbox ~border_width:5 ~spacing:5 ~packing:v#pack () in
      let b = GButton.button ~use_mnemonic:true ~label:"_Close" ~packing:(h#pack ~from:`END) ()
      in
      object(self)
        initializer
          ignore (b#connect#clicked (fun _ -> self#close));
          hw#show ()
        method close = hw#destroy ()
        method present = hw#present ()
      end
    ;;
    (* ***)
    (*** error_display *)
    class error_display ~packing () =
      let tags_parse_head = GText.tag ~name:"parse_head" () in
      let tags_query = GText.tag ~name:"tags_query" () in
      let tags_query_highlight = GText.tag ~name:"tags_query_highlight" () in
      let tags_ast = GText.tag ~name:"tags_ast" () in
      let errors_tag_table = GText.tag_table () in
      let errors_buffer = GText.buffer ~tag_table:errors_tag_table () in
      let errors_frame = GBin.frame ~packing () in
      let errors_sw =
        GBin.scrolled_window
          ~packing:errors_frame#add ~height:80
          ~hpolicy:`AUTOMATIC
          ~vpolicy:`AUTOMATIC
          ()
      in
      let errors_view = GText.view
                   ~packing:errors_sw#add
                   ~editable:false
                   ~cursor_visible:false
                   ~border_width:1
                   ~buffer:errors_buffer
                   ~wrap_mode:`WORD
                   ()
      in
      let ast_font_size = 7 in
      object(self)
        initializer
          errors_tag_table#add tags_parse_head#as_tag;
          errors_tag_table#add tags_query_highlight#as_tag;
          errors_tag_table#add tags_ast#as_tag;
          tags_parse_head#set_property (`STYLE `ITALIC);
          tags_query_highlight#set_property (`BACKGROUND "red");
          tags_ast#set_property (`FONT (sf "Monospace %d" ast_font_size));
          (* tags_ast#set_property (`SIZE 8) *)

        method show_ast q =
          let b = errors_view#buffer in
          b#set_text "";
          b#insert ~tags:[tags_parse_head] "Query syntax tree:\n";
          let f = Format.make_formatter
            (fun u i m ->
               b#insert ~tags:[tags_ast] (to_utf8 (String.sub u i m)))
            (fun _ -> ())
          in
          let n = 
            (match errors_view#get_window `TEXT with
            | Some w ->
                let (n,m) = Gdk.Drawable.get_size w in
                max 5 (n / (1 + ast_font_size))
            | None -> 30)
          in
          let n = 3 * n / 4 in
          Format.pp_set_max_indent f (2 * n / 3);
          Format.pp_set_margin f n;
          Ast.dump f q
        method no_parse_error () = errors_buffer#set_text ""
        method show_message msg =
          let b = errors_view#buffer in
          b#set_text "";
          b#insert ~tags:[tags_parse_head] (to_utf8 msg)
        method show_parse_error i j x w =
          let b = errors_view#buffer in
          b#set_text "";
          let m = String.length w in
          if m = 0 then
            b#insert ~tags:[tags_parse_head] "Empty query."
          else
            begin
              if i = j then
                if i >= m - 1 then
                  begin
                    b#insert ~tags:[tags_parse_head] (sf "At end of query: %s.\n" x);
                    b#insert ~tags:[] (to_utf8 w);
                    b#insert ~tags:[tags_query_highlight] " "
                  end
                else
                  begin
                    b#insert ~tags:[tags_parse_head] (sf "At character %d: %s.\n" (i + 1) x);
                    if i > 0 then b#insert ~tags:[] (to_utf8 (String.sub w 0 (min (m - 1) i)));
                    if i < m then b#insert ~tags:[tags_query_highlight] (to_utf8 (String.sub w i 1));
                    if i + 1 < m then b#insert ~tags:[] (to_utf8 (String.sub w (j + 1) (m - j - 1)))
                  end
              else
                begin
                  b#insert ~tags:[tags_parse_head]
                    (to_utf8 (sf "Between characters %d and %d: %s.\n"
                                (i + 1)
                                (j + 1)
                                x));
                  if i > 0 then b#insert ~tags:[] (to_utf8 (String.sub w 0 (min (m - 1) i)));
                  if i < m then
                    b#insert
                      ~tags:[tags_query_highlight]
                      (to_utf8 (String.sub w i ((min (m - 1) j) - i + 1)));
                  if j + 1 < m then b#insert ~tags:[] (to_utf8 (String.sub w (j + 1) (m - j - 1)))
                end
            end
      end
    ;;
    (* ***)
    (*** query_book *)
    module SM = Map.Make(String);;
    class query_book ~packing () =
      let fr = GBin.frame ~packing () in
      let vb = GPack.vbox ~packing:fr#add () in
      let label = GMisc.label ~use_underline:true ~text:"_Variables" () in
      let _ = fr#set_label_widget (Some(label#coerce)) in
      let hb = GPack.hbox ~border_width:5 ~packing:vb#add () in
      let sw = GBin.scrolled_window
                   ~hpolicy:`AUTOMATIC
                   ~vpolicy:`AUTOMATIC
                   ~packing:hb#add
                   ()
      in
      let vb = GPack.vbox ~border_width:5 ~packing:hb#pack () in
      let button_edit = GButton.button ~use_mnemonic:true ~label:"_Edit" ~packing:vb#pack () in
      let button_delete = GButton.button ~use_mnemonic:true ~label:"_Delete" ~packing:vb#pack () in
      let button_use = GButton.button ~use_mnemonic:true ~label:"_Use" ~packing:vb#pack () in
      let queries = GList.clist
                 ~titles:["Variable";"Request";"Population"]
                 ~titles_active:false
                 ~packing:sw#add
                 ()
      in
      let _ = label#set_mnemonic_widget (Some(queries#coerce)) in
      object(self)
        val book : (string * Dpkg.IS.t * Ara.query) SM.t ref = ref SM.empty
        val mutable current_entry = None
        val mutable edit_callback : string -> unit = ignore
        initializer
          ignore (queries#connect#select_row
            ~callback:(fun ~row ~column ~event ->
              current_entry <- Some(queries#get_row_data row)));
          ignore (button_delete#connect#clicked
            (fun _ ->
              match current_entry with
              | None -> flash "No entry to delete."
              | Some x ->
                  book := SM.remove x !book;
                  current_entry <- None;
                  self#repopulate));
          ignore (button_use#connect#clicked
            (fun _ ->
              match current_entry with
              | None -> flash "No entry to edit."
              | Some x ->
                  let (w,_,_) = SM.find x !book in
                  edit_callback (to_utf8 w)));
          ignore (button_edit#connect#clicked
            (fun _ ->
              match current_entry with
              | None -> flash "No entry to use."
              | Some x ->
                  let (w,_,_) = SM.find x !book in
                  edit_callback (to_utf8 (sf "$%s := %s" x w))));
          queries#set_column ~auto_resize:true 0;
          queries#set_column ~auto_resize:true 1;
          queries#set_column ~auto_resize:true 2
        method repopulate =
          queries#freeze ();
          queries#clear ();
          SM.iter (fun k (w,r,_) ->
              let r = queries#append
                    [to_utf8 k; to_utf8 w; sf "%d" (Dpkg.IS.cardinal r)] in
              queries#set_row_data r k)
            !book;
          queries#thaw ()
        method book = book
        method set_edit_callback f = edit_callback <- f
      end;;
    (* ***)
    (*** compute_query *)
    exception Variable_not_found of string;;
    let compute_query sm db q w =
      (* let sm = query_book#book in *)
      let pl = Ara.compute_query db
        ~get:(fun id ->
          try
            let (_,r,_) = SM.find id !sm in r
          with
          | Not_found -> raise (Variable_not_found id))
        ~set:(fun id r s1 s2 q ->
          let w' =
            try
              String.sub w s1 (s2 - s1)
            with
            | _ -> sf "??? %d,%d" s1 s2
          in
          sm := SM.add id (w',r,q) !sm)
      q
      in
      pl
    ;;
    (* ***)
    (*** requests *)
    class requests ~results ~query_book ~packing () =
      let f2_v = GPack.vbox
        ~border_width:5
        ~spacing:5
        ~packing
        ()
      in
      let query_hbox = GPack.hbox ~packing:f2_v#pack ~spacing:5 () in
      let query_label = GMisc.label ~use_underline:true ~text:"_Query:" ~packing:query_hbox#pack () in
      let query_combo = GEdit.combo
        ~enable_arrow_keys:true
        ~allow_empty:false
        ~case_sensitive:true
        ~popdown_strings:["section:(games or gnome) and (tetris or netris)"]
        ~packing:query_hbox#add
        ()
      in
      let query_edit = query_combo#entry in
      let _ = query_label#set_mnemonic_widget (Some(query_edit#coerce)) in
      let button_launch = GButton.button
                            ~use_mnemonic:true
                            ~label:"Run query"
                            ~packing:query_hbox#pack ()
      in
      let p0 = GPack.paned `VERTICAL ~packing:f2_v#add () in
      let error_display = new error_display ~packing:p0#add1 () in
      let database_subscription = database#subscribe () in
      object(self)
        initializer
          query_combo#disable_activate ();
          ignore (button_launch#connect#clicked ~callback:(fun _ -> self#launch));
          ignore (query_edit#connect#activate ~callback:(fun _ ->
            let l = query_combo#list#all_children in
            let w = query_edit#text in
            if not (List.exists
              (fun li -> List.exists (fun ll ->
                (GMisc.label_cast ll)#text = w) li#all_children) l) then
              begin
                let li = GList.list_item ~label:w () in
                query_combo#list#insert li 0;
              end;
            self#launch))
        method set_query w = query_edit#set_text w
        method launch_parsed q w =
          try
            database_subscription#with_last_issue
              (fun db ->
                try
                  error_display#show_ast q;
                  Computation.launch_job
                  ((fun () ->
                    let pl = compute_query query_book#book db q w in
                    GtkThread.async (fun () ->
                      query_book#repopulate;
                      results#set_package_list db pl) ()),
                      sf "Process query %s" w)
                with
                | Computation.Busy -> flash "Busy !")
          with
          | Glib.Convert.Error(e,s) ->
              error_display#show_message
              (sf "Illegal, non ISO-8859-1 characters in query. (%s)" s);
          | Publication.No_issue -> flash "Database unavailable. Try: apt-get update"
          | x ->
              flash (sf "Exception: %S" (Printexc.to_string x))
        method launch =
          catch_utf8 () (fun () ->
            let w = from_utf8 (query_edit#text) in
            try
              self#launch_parsed (Ara.statement_of_string w) w
            with
            | Ara.Parse_error(i,j,x) ->
              error_display#show_parse_error i j x w;
              flash "Parse error."
            | x -> flash (sf "Error: %s." (Printexc.to_string x)))
      end
    ;;
    (* ***)
    (*** section_chooser *)
    let id = ref 0
    class section_chooser ~(selection_magazine : string list Publication.magazine) () =
      let id = incr id; !id in
      let sd =
        GWindow.window
          ~width:200
          ~height:500
          ~title:"Debian sections"
          ~modal:false
          ~show:false
          ()
      in
      let vb1 = GPack.vbox ~border_width:5 ~spacing:5 ~packing:sd#add () in

      (* search paths *)
      let f1 = GBin.frame ~label:"Available sections" ~packing:vb1#add () in
      let vb11 = GPack.vbox ~border_width:5 ~spacing:5 ~packing:f1#add () in
      let hb11 = GPack.hbox ~border_width:5 ~spacing:5 ~packing:vb11#add () in
      let sw111 = GBin.scrolled_window
        ~hpolicy:`AUTOMATIC
        ~vpolicy:`AUTOMATIC
        ~packing:hb11#add
        ()
      in
      let sec = GList.clist
                 ~titles:["Section"]
                 ~titles_active:false
                 ~selection_mode:`MULTIPLE
                 ~packing:sw111#add
                 ()
      in
      (* buttons *)
      let hb3 = GPack.hbox ~border_width:5 ~spacing:5 ~packing:vb1#pack () in
      let button_close = GButton.button ~use_mnemonic:true ~label:"_Close" ~packing:hb3#add () in
      let db_subscription = database#subscribe () in
      let sel_subscription = selection_magazine#subscribe () in
      (* let bundle = new Publication.bundle db_subscription sel_subscription ~callback:ignore in *)
      object(self)
        val mutable current_row = None
        val mutable sections = []
        val mutable selection = []
        val mutable selection' = []
        val mutable dont_publish = false
        initializer
          ignore (button_close#connect#clicked (fun _ -> sd#destroy ()));
          ignore (sd#connect#destroy ~callback:(fun () ->
            db_subscription#cancel;
            sel_subscription#cancel));
          sel_subscription#set_callback
            (fun sel -> selection <- sel;
                        GtkThread.async (fun () ->
                          sec#freeze ();
                          self#reselect;
                          sec#thaw ()) ());
          db_subscription#set_callback (fun db -> self#recompute_section_list db);
          ignore (sec#connect#select_row ~callback:(self#new_selection ~select:true));
          ignore (sec#connect#unselect_row ~callback:(self#new_selection ~select:false));
          db_subscription#tick;
          sel_subscription#tick;
          sd#show ()

        method new_selection ~select ~row ~column ~event =
          if not dont_publish then
            begin
              let x = sec#get_row_data row in
              if select then
                selection <- x::selection
              else
                selection <- List.filter ((<>) x) selection;
              sel_subscription#publish selection
            end

        method private recompute_section_list db =
          sections <- sections_of_database db;
          GtkThread.async (fun () -> self#repopulate) ()

        method private reselect =
          dont_publish <- true;
          let m = sec#rows in
          for i = 0 to m - 1 do
            let x = sec#get_row_data i in
            if List.mem x selection <> List.mem x selection' then
              begin
                if List.mem x selection then
                  sec#select i 0
                else
                  sec#unselect i 0
              end
          done;
          selection' <- selection;
          dont_publish <- false

        method private repopulate =
          sec#freeze ();
          sec#clear ();
          List.iter (fun x ->
            let i = sec#append [to_utf8 x] in
            sec#set_row_data i x) sections;
          self#reselect;
          sec#thaw ()
      end
    ;;
    (* ***)
    (*** simple_requests *)
    exception Shit;;
    class simple_requests ~results ~requests ~packing () =
      let vbox = GPack.vbox ~packing ~border_width:5 ~spacing:10 () in
      let hbox1 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in
      let name_label = GMisc.label ~text:"Package name contains:" ~packing:hbox1#pack () in
      let name_entry = GEdit.entry ~packing:hbox1#add () in

      let hbox2 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in
      let version_label = GMisc.label ~text:"Version is:" ~packing:hbox2#pack () in
      let (version_combo,_) = GEdit.combo_box_text
        ~strings:["Don't mind";
                  "< (strictly less than)";
                  "<= (less than or equal to)";
                  "= (equal to)";
                  "> (greater than)";
                  ">= (greater than or equal to)"]
        ~packing:hbox2#add
        ()
      in
      let _ = version_combo#set_active 0 in
      let version_entry = GEdit.entry ~packing:hbox2#add () in

      let hbox3 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in
      let section_label = GMisc.label ~text:"In sections:" ~packing:hbox3#pack () in
      let section_entry = GEdit.entry ~packing:hbox3#add () in
      let section_button = GButton.button
                            ~use_mnemonic:true
                            ~label:"_Choose"
                            ~packing:(hbox3#pack ~from:`END) ()
      in

      let hbox7 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in
      let install_label = GMisc.label ~text:"Installation status:" ~packing:hbox7#pack () in
      let (install_combo,_) = GEdit.combo_box_text
        ~strings:["Don't mind";
                  "Installed";
                  "Never installed";
                  "Deinstalled, still config files";
                  "Purged"]
        ~packing:hbox7#add
        ()
      in
      let _ = install_combo#set_active 0 in



      let hbox4 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in
      let description_label = GMisc.label ~text:"Description contains:" ~packing:hbox4#pack () in
      let vbox41 = GPack.vbox ~packing:hbox4#add ~spacing:5 () in

      let hbox411 = GPack.hbox ~packing:vbox41#add ~spacing:5 () in
      let all_of_label = GMisc.label ~text:"All of these words:" ~packing:hbox411#pack () in
      let all_of_entry = GEdit.entry ~packing:hbox411#add () in

      let hbox412 = GPack.hbox ~packing:vbox41#add ~spacing:5 () in
      let some_of_label = GMisc.label ~text:"Some of these words:" ~packing:hbox412#pack () in
      let some_of_entry = GEdit.entry ~packing:hbox412#add () in

      let hbox413 = GPack.hbox ~packing:vbox41#add ~spacing:5 () in
      let none_of_label = GMisc.label ~text:"None of these words:" ~packing:hbox413#pack () in
      let none_of_entry = GEdit.entry ~packing:hbox413#add () in

      let hbox5 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in
      let depends_label = GMisc.label ~text:"Depends on:" ~packing:hbox5#pack () in
      let depends_entry = GEdit.entry ~packing:hbox5#add () in

      (*let hbox6 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in*)
      let not_depends_label = GMisc.label ~text:"but not on:" ~packing:hbox5#pack () in
      let not_depends_entry = GEdit.entry ~packing:hbox5#add () in

      let hbox8 = GPack.hbox ~packing:vbox#pack ~spacing:5 () in
      let size_label = GMisc.label ~text:"Size:" ~packing:hbox8#pack () in
      let (size_combo,_) = GEdit.combo_box_text
        ~strings:["Don't mind";
                  "<";
                  ">"]
        ~packing:hbox8#add
        ~width:60
        ()
      in
      let _ = size_combo#set_active 0 in
      let size_entry = GEdit.entry ~packing:hbox8#add () in
      let (size_unit_combo,_) = GEdit.combo_box_text
        ~strings:["B";
                  "KiB";
                  "MiB"]
        ~packing:hbox8#add
        ()
      in
      let _ = size_unit_combo#set_active 1 in

      let hbox9 = GPack.hbox ~packing:(vbox#pack ~from:`END) ~spacing:5 () in
      let launch_button = GButton.button
                            ~use_mnemonic:true
                            ~label:"Run query"
                            ~packing:(hbox9#pack ~from:`END) ()
      in
      let sections = new Publication.magazine in
      let section_subscription = sections#subscribe () in
      let database_subscription = database#subscribe () in
      object(self)
        initializer
          ignore (launch_button#connect#clicked ~callback:(fun _ -> self#launch));
          section_subscription#set_callback (fun x ->
            Debug.debug 0 "receive";
            let y = String.concat " " x in
            section_entry#set_text (to_utf8 y));
          ignore (section_entry#connect#activate ~callback:(fun _ ->
            Debug.debug 0 "activated";
            catch_utf8 () (fun () ->
            try
              let w = from_utf8 section_entry#text in
              let l = Util.parse_strings w in
              database_subscription#with_last_issue (fun db ->
                Debug.debug 0 "dbli";
                let secs = sections_of_database db in
                List.iter (fun x ->
                  if not (List.mem x secs) then
                    begin
                      flash (sf "Unknown section %S." x);
                      raise Shit
                    end) l);
              Debug.debug 0 "publish";
              section_subscription#publish l
            with
            | Shit -> ()
            | x -> flash (sf "Bad section list: %s." (Printexc.to_string x)))));
          ignore (section_button#connect#clicked ~callback:(fun _ ->
            ignore (section_entry#misc#activate ());
            let sd = new section_chooser ~selection_magazine:sections () in
            ()))
        method launch =
          try
            let r = ref None in
            let put x =
              match !r with
              | None -> r := Some x
              | Some y -> r := Some(Ast.And(x,y))
            in
            let do_field ?(negate=false) ?(disjunct=false) fd w =
              let negif x = if negate then Ast.Not(x) else x in
              let contents =
                try
                  Util.parse_strings w
                with
                | Failure(x) ->
                    flash (sf "Field %s: %s." fd x);
                    raise Shit
              in
              let options = [Ast.Case_insensitive] in
              begin
                match contents with
                | [] -> ()
                | [x] ->
                  put (negif
                    (Ast.Atom(
                      Ast.Matches(Ast.This_field(fd),
                                  Ast.Regular(Util.reg_of_string x, options)))))
                | x::r ->
                    put (Ast.Meta(Ast.With_field(Ast.This_field(fd)),
                         (List.fold_left
                            (fun x y ->
                              let z = 
                                Ast.Atom(Ast.Matches(
                                  Ast.Current_field, Ast.Regular(Util.reg_of_string y, options)))
                              in
                              if disjunct then
                                if negate then Ast.And(x,z) else Ast.Or(x,z)
                              else
                                if negate then Ast.Or(x,Ast.Not(z)) else Ast.And(x,z))
                            (negif
                              (Ast.Atom(Ast.Matches(
                                Ast.Current_field, Ast.Regular(Util.reg_of_string x, options)))))
                            r)))
              end
            in
            catch_utf8 () (fun () ->
            do_field "package" (from_utf8 (name_entry#text));
            do_field "description" (from_utf8 (all_of_entry#text));
            do_field "description" ~disjunct:true (from_utf8 (some_of_entry#text));
            do_field "description" ~negate:true (from_utf8 (none_of_entry#text));
            do_field "depends" (from_utf8 (depends_entry#text));
            do_field "depends" ~negate:true (from_utf8 (not_depends_entry#text));
            do_field "section" ~disjunct:true (from_utf8 (section_entry#text));
            begin
              let ver = from_utf8 (version_entry#text) in
              let vercomp = version_combo#active in
              if ver <> "" && vercomp > 0 then
                put (Ast.Atom(Ast.Matches(Ast.This_field("version"),
                  (match vercomp with
                   | 1 -> Ast.Lexicographic_lt(ver)
                   | 2 -> Ast.Lexicographic_le(ver)
                   | 3 -> Ast.Exact(ver)
                   | 4 -> Ast.Lexicographic_ge(ver)
                   | _ -> Ast.Lexicographic_gt(ver)))))
            end;
            begin
              let install = install_combo#active in
              if install <> 0 then
                put (Ast.Atom(Ast.Matches(Ast.This_field("status"),
                      Ast.Exact(match install with
                      | 1 -> "install ok installed"
                      | 2 -> ""
                      | 3 -> "deinstall ok config-files"
                      | _ -> "purge ok not-installed"))))
            end;
            begin
              let size_decimal = from_utf8 (size_entry#text) in
              let size_comp = size_combo#active in
              let size_unit = size_unit_combo#active in
              if size_decimal <> "" && size_comp > 0 then
                try
                  let size = float_of_string size_decimal in
                  let size = match size_unit with
                  | 0 -> size
                  | 1 -> size *. 1024.0
                  | _ -> size *. 1048576.0
                  in
                  if size < 0.0 then raise Shit;
                  let size = Int64.to_string (Int64.of_float size) in
                  put (Ast.Atom(Ast.Matches(Ast.This_field("size"),
                    (match size_comp with
                     | 1 -> Ast.Lexicographic_lt(size)
                     | _ -> Ast.Lexicographic_gt(size)))))
                with
                | _ ->
                    flash "Bad package size.";
                    raise Shit
              else
                ()
            end;
            match !r with
            | None -> requests#launch_parsed (Ast.Display(Ast.True)) "(simple request)"
            | Some q -> requests#launch_parsed (Ast.Display(q)) "(simple request)")
          with
          | Shit -> ()
      end
    ;;
    (* ***)
    (*** request_frame *)
    class request_frame ~results ~packing () =
      (* let pane = GPack.paned `VERTICAL ~packing ~border_width:5 () in *)
      let notebook1 = GPack.notebook ~packing () in (* Advanced, Simple *)

      let query_book = new query_book
        ~packing:(ign (notebook1#append_page ~tab_label:((GMisc.label ~text:"Variables" ())#coerce))) ()
      in

      let requests = new requests
        ~results
        ~query_book
        ~packing:(ign (notebook1#prepend_page ~tab_label:((GMisc.label ~text:"Advanced" ())#coerce))) ()
      in

      let syntax_help = new syntax_help
        ~packing:(ign (notebook1#append_page
          ~tab_label:((GMisc.label ~text:"Syntax help" ())#coerce))) ()
      in

      let simple_requests = new simple_requests
        ~results
        ~requests
        ~packing:(ign (notebook1#append_page ~tab_label:((GMisc.label ~text:"Simple" ())#coerce))) ()
      in

      object(self)
        initializer
          query_book#set_edit_callback requests#set_query;
        method requests = requests
      end
    ;;
    (* ***)
    (*** load_database, reload_database *)
    let load_database ?(after = fun _ -> ()) (dbfn:(string * string) list) =
      try
        Computation.launch_job
          ((fun () ->
             try
               let dbfns =
                 List.fold_left (fun l (path,patt) ->
                   let fns = Slurp.slurp path in
                   let re = Str.regexp patt in
                   let rec loop curpath (l : string list) = function
                     | Slurp.File(fn,_) ->
                        if try ignore (Str.search_forward re fn 0); true with Not_found -> false then
                          (Filename.concat curpath fn)::l
                        else
                          l
                     | Slurp.Directory(d,fl) ->
                         List.fold_left (fun l t -> loop (Filename.concat curpath d) l t) l fl
                     | Slurp.Error(_,_) -> l
                   in
                   loop "" l fns) [] dbfn
                in
                let progress =
                  let last = ref 0.0
                  in
                  fun fn count ->
                    let t = Unix.gettimeofday () in
                    if t > !last +. 0.5 then
                      begin
                        GtkThread.async
                          flash
                          (sf "Loaded %d packages (processing %S)" count fn);
                        last := t
                      end;
                in
                let db' = Dpkg.load ~fast:!Opt.fast ~progress dbfns in
                database#publish `Everyone db';
                after db'
             with
             | x -> debug 0 (sf "Could not load database: %s. Try: apt-get update\n" (Printexc.to_string x))),
           "Load database...")
      with
      | Computation.Busy -> flash ("Busy...")
    ;;

    (* load_database ***)
    (*** Layout... *)
    let p0 = GPack.paned `VERTICAL ~packing:v0#add ();;
    let p1 = GPack.paned `HORIZONTAL ~packing:(p0#pack2 ~shrink:false) ();;
    let st1 = GMisc.statusbar ~packing:v0#pack ();;
    let st1_ctx_exception = st1#new_context ~name:"Exception" ;;
    let _ = flash_context := Some(st1_ctx_exception);;
    let package_display = new package_display ~packing:(p0#pack1 ~shrink:true) ();;
    let results = new results_display ~popup_entries:package_display#popup_entries
        ~packing:(p1#pack1 ~shrink:true) ();;
    let request_frame = new request_frame ~results ~packing:(p1#pack2 ~shrink:false) ();;
    let _ = results#set_when_selected package_display#set_package;;
    (* ***)
    (*** bookmark_menu_callback *)
    let bookmark_menu_callback ~before ~menu l =
      try
        let set_package pn pv () =
          database#with_last_issue
            (fun db ->
             try
               let i = Dpkg.find_package db pn pv in
               package_display#set_package db i;
               flash (to_utf8 (sf "Selected %s (%s)" pn pv))
             with
             | Not_found ->
                 flash (to_utf8 (sf "Package %s (%s) not found !" pn pv)))
        in
        database#with_last_issue
          (fun db ->
            let entries =
              before
              @
              (List.map (fun (pn, pv) ->
                 let lb = to_utf8 (sf "%s (%s)" pn pv) in
                 `I(lb, set_package pn pv)) l)
            in
            List.iter (fun x -> menu#remove x) menu#all_children ;
            GToolbox.build_menu (menu : GMenu.menu) ~entries)
      with
      | Publication.No_issue -> flash "No database loaded."
    ;;
    (* ***)
    (*** main_menu *)
    module Do =
      struct
        let syntax_help =
          let hw = ref None in
          fun () ->
            match !hw with
            | None ->
                hw := Some(new help_window ~on_close:(fun _ -> hw := None) ())
            | Some(hw') -> hw'#present
        ;;

        let quit () =
          bookmarks#save;
          Config.current#save;
          GtkMain.Main.quit ()
        ;;

        let about () =
          let md =
            GWindow.message_dialog
            ~message:Help.gui_about
            ~message_type:`INFO
            ~buttons:GWindow.Buttons.ok
            ~title:"About Xara"
            ~modal:true
            ~show:true
            ()
          in
          ignore (md#run ());
          md#destroy ()
        ;;

        let enter_query =
          let last_query = ref "" in
          fun () ->
            match
              GToolbox.input_string
                ~title:"Enter query to process"
                ~ok:"Run query"
                ~text:(to_utf8 !last_query)
                "Please enter your request."
            with
            | None -> ()
            | Some w ->
                last_query := w;
                request_frame#requests#set_query w;
                request_frame#requests#launch
        ;;

        let apt_update = apt_update;;

        let reload_database () =
          flash "Reloading database...";
          load_database (database_paths ())
            ~after:(fun db -> results#set_package_list db [])
        ;;

        let configure () =
          ignore (new configure Config.current ())
        ;;

        let show_memory () =
          let words =
            let (miw,prw,maw) = Gc.counters () in
            (miw +. maw -. prw) /. 1000000.0
          in
          let pgsz = Config.current#get_int ~default:4096 "cli.misc.page_size" in
          let (rsz,vsz) = Util.proc_get_rsz_vsz () in
          let md =
            GWindow.message_dialog
              ~title:"Memory usage"
              ~message_type:`INFO
              ~buttons:GWindow.Buttons.ok
              ~message:(sf 
                        "Memory usage is %d pages virtual, %d pages resident.\n\
                         With a page size of %d bytes this gives %.1fMiB virtual \
                         and %.1fMiB resident.\n\
                         Approximatively %.1f million words have been allocated.\n\
                         Current backend: %s"
                         rsz vsz
                         pgsz
                         ((float pgsz) *. (float rsz) /. 1048576.0)
                         ((float pgsz) *. (float vsz) /. 1048576.0)
                         words
                         Dpkg.backend)
              ~modal:true
              ~show:true
              ()
          in
          ignore (md#run ());
          md#destroy ()
        ;;

        let compact_heap () =
          i_am_busy ();
          let (rsz1,vsz1) = Util.proc_get_rsz_vsz () in
          Gc.compact ();
          let (rsz2,vsz2) = Util.proc_get_rsz_vsz () in
          flash (sf "Compaction saved %d resident and %d virtual pages."
                  (rsz1 - rsz2) (vsz1 - vsz2));
          i_am_ready ()
        ;;

        let print () = package_display#print;;
        let export () = package_display#export;;
        let install () = package_display#install;;
        let remove () = package_display#remove;;
        let bookmark () = package_display#bookmark;;
        let unbookmark () = package_display#unbookmark;;
        let clear_bookmarks () = package_display#clear_bookmarks;;
        let bookmarks_hook (before, menu) =
          bookmarks#set_callback (Some(bookmark_menu_callback ~before ~menu));;
      end
    ;;

    let main_menu_entry =
      [
        `M("_Xara",ignore,
           [`I("_Print",                  Do.print);
            `I("E_xport (as plain text)", Do.export);
            `S;
            `I("_Quit",                   Do.quit)
           ]);
        `M("Book_marks",                  Do.bookmarks_hook,
           [`I("_Add package",            Do.bookmark);
            `I("_Remove package",         Do.unbookmark);
            `I("_Clear bookmarks",        Do.clear_bookmarks);
            `S]);
        `M("_Tools", ignore,
           [`I("Enter _query",            Do.enter_query);
            `M("APT",
              [`I("_Install",            Do.install);
               `I("_Remove",             Do.remove);
               `S;
               `I("_Update",             Do.apt_update "xara.commands.update");
               `I("Re_load database",    Do.reload_database);
               `S;
               `I("Up_grade",            Do.apt_update "xara.commands.upgrade");
               `I("_Dist-upgrade",       Do.apt_update "xara.commands.dist_upgrade")]);
            `M("_Misc",
              [`I("Show _memory usage",  Do.show_memory);
               `I("Compact _heap",       Do.compact_heap)])]);
        `M("Se_ttings", ignore,
           [`I("_Configure",              Do.configure);
            (*`I("GUI preferences",        (fun () -> ()))*)]);
        `M("_Help", ignore,
           [`I("_Syntax help",            Do.syntax_help);
            `I("_About",                  Do.about)])
      ]
    ;;

    let _ =
      let create_menu label menubar =
        let item = GMenu.menu_item ~use_mnemonic:true ~label ~packing:menubar#append () in
        GMenu.menu ~packing:item#set_submenu ()
      in
      List.iter (function `M(x,y,z) ->
        let menu = create_menu x menu_bar in
        GToolbox.build_menu menu ~entries:z;
        y (z, menu)) main_menu_entry
    ;;
    (* ***)
    (*** Main... *)
    let main () =
      follow_window_size ~window ~name:"main";
      Computation.init ();
      ignore (window#connect#destroy ~callback:(fun _ -> Do.quit ()));
      window#show ();
      load_database (database_paths ()) ~after:(fun db -> bookmarks#load);
      GtkThread.main ()
    ;;
    (* ***)
end
(* ***)

let _ =
  (* load config *)
  List.iter (fun (fn,ex) ->
    if fn <> !Opt.config_file or
       (!Opt.user_specified_config_file & fn = !Opt.config_file) or
       (match ex with Sys_error(_) -> false | _ -> true)
    then
      Printf.printf "Error loading config file %S: %s.\n" fn (Printexc.to_string ex))
    (Config.load ());

  if !Opt.dump_config then
    begin
      Configfile.dump ~show_status:true Format.std_formatter
        (Configfile.get_config Config.current#context);
      Format.pp_print_flush Format.std_formatter ()
    end
  else
    (* Fix for LablGTK2/Qt engine crashes *)
    let fn = Config.current#get_string "xara.gtkrc" ~default:"/etc/xara-gtkrc-2.0" in
    if Sys.file_exists fn then GtkMain.Rc.add_default_file fn;
    (* Run stuff. *)
    if !Opt.very_slow then
      let module M = Make(Dpkg.DBFS) in
      M.main ()
    else
      let module M = Make(Dpkg.DBRAM) in
      M.main ()
;;
