From 769d3d04b974276ff3a39f140228c07f3332ac5c Mon Sep 17 00:00:00 2001
From: Benjamin Monate <benjamin.monate@cea.fr>
Date: Sat, 6 Sep 2008 19:02:02 +0000
Subject: [PATCH] new experimental filetree using lablgk custom models
---
.make-clean-stamp | 2 +-
Makefile.in | 16 +-
configure.in | 7 +
src/gui/.cvsignore | 1 +
src/gui/filetree_custom.ml | 382 +++++++++++++++++++
src/gui/{filetree.ml => filetree_default.ml} | 11 +-
6 files changed, 407 insertions(+), 12 deletions(-)
create mode 100644 src/gui/filetree_custom.ml
rename src/gui/{filetree.ml => filetree_default.ml} (94%)
diff --git a/.make-clean-stamp b/.make-clean-stamp
index 00750edc07d..b8626c4cff2 100644
--- a/.make-clean-stamp
+++ b/.make-clean-stamp
@@ -1 +1 @@
-3
+4
diff --git a/Makefile.in b/Makefile.in
index 3bc90b6d287..b332085bf76 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -69,6 +69,7 @@ LABLGLADECC= @LABLGLADECC@ -hide-default
HAS_GTKSOURCEVIEW=@HAS_GTKSOURCEVIEW@
HAS_GNOMECANVAS=@HAS_GNOMECANVAS@
HAS_LEGACY_GTKSOURCEVIEW=@HAS_LEGACY_GTKSOURCEVIEW@
+HAS_LABLGTK_CUSTOM_MODEL=@HAS_LABLGTK_CUSTOM_MODEL@
OTAGS = @OTAGS@
DOT = @DOT@
@@ -1464,6 +1465,19 @@ OPT_GUI_LIBS += lablgnomecanvas.cmxa
GUICMO = view_graph/viewGraph view_graph/viewGraph_select
endif
+src/gui/filetree.ml: Makefile
+
+ifeq ($(HAS_LABLGTK_CUSTOM_MODEL),yes)
+src/gui/filetree.ml: src/gui/filetree_custom.ml
+ $(CP) $< $@
+ @chmod -w $@
+else
+src/gui/filetree.ml: src/gui/filetree_default.ml
+ $(CP) $< $@
+ @chmod -w $@
+endif
+GENERATED += src/gui/filetree.ml
+
GUICMO += gtk_helper source_viewer source_manager warning_manager \
pretty_source filetree design project_manager journal_manager \
about_dialog gui_boot
@@ -1901,7 +1915,7 @@ display_dependencies: datatype_dependencies.svg computation_dependencies.svg
.PHONY: install
install:
- $(MAKE) -C ocamlgraph install
+# $(MAKE) -C ocamlgraph install
$(MKDIR) $(DESTDIR)$(BINDIR)
$(MKDIR) $(DESTDIR)$(datadir)
$(MKDIR) $(DESTDIR)$(plugindir)
diff --git a/configure.in b/configure.in
index 0dafa305495..010c8d28812 100644
--- a/configure.in
+++ b/configure.in
@@ -822,6 +822,12 @@ configure_library \
$OCAMLLIB/lablgtk2/lablgtk.cma \
"lablgtk2 not found."
+HAS_LABLGTK_CUSTOM_MODEL=no
+AC_ARG_ENABLE(custommodel,
+[ --enable-custommodel
+ use a custom tree model in GUI. Need to have a recent lablgtk version],
+HAS_LABLGTK_CUSTOM_MODEL=yes,HAS_LABLGTK_CUSTOM_MODEL=no)
+
# Gtksourceview
###############
REQUIRE_GTKSOURCEVIEW=
@@ -1117,6 +1123,7 @@ AC_SUBST(HAS_LABLGTK)
AC_SUBST(HAS_GTKSOURCEVIEW)
AC_SUBST(HAS_LEGACY_GTKSOURCEVIEW)
AC_SUBST(HAS_GNOMECANVAS)
+AC_SUBST(HAS_LABLGTK_CUSTOM_MODEL)
AC_SUBST(LABLGLADECC)
AC_SUBST(HAS_LABLGLADECC)
AC_SUBST(JCCMO)
diff --git a/src/gui/.cvsignore b/src/gui/.cvsignore
index ec33ab274d9..80069ca3ca7 100644
--- a/src/gui/.cvsignore
+++ b/src/gui/.cvsignore
@@ -4,4 +4,5 @@ version.ml
*.annot
*.cm*
*.o
+filetree.ml
.DS_Store
diff --git a/src/gui/filetree_custom.ml b/src/gui/filetree_custom.ml
new file mode 100644
index 00000000000..90663c63a36
--- /dev/null
+++ b/src/gui/filetree_custom.ml
@@ -0,0 +1,382 @@
+(**************************************************************************)
+(* *)
+(* This file is part of Frama-C. *)
+(* *)
+(* Copyright (C) 2007-2008 *)
+(* CEA (Commissariat à l'Énergie Atomique) *)
+(* *)
+(* you can redistribute it and/or modify it under the terms of the GNU *)
+(* Lesser General Public License as published by the Free Software *)
+(* Foundation, version 2.1. *)
+(* *)
+(* It is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU Lesser General Public License for more details. *)
+(* *)
+(* See the GNU Lesser General Public License version 2.1 *)
+(* for more details (enclosed in the file licenses/LGPLv2.1). *)
+(* *)
+(**************************************************************************)
+
+open Extlib
+open Ast_info
+open Cil_types
+open Cil
+open CilE
+open Format
+open Db
+open Db_types
+open Pretty_source
+open Gtk_helper
+open Cilutil
+
+class type t = object
+ method model : GTree.model_filter
+ method set_file_attribute: ?strikethrough:bool -> ?visible:bool -> ?text:string -> string -> unit
+ method set_global_attribute: ?strikethrough:bool -> ?visible:bool -> ?text:string -> Cil_types.varinfo -> unit
+ method add_select_function :
+ (was_activated:bool -> activating:bool -> Cil_types.global list -> unit) -> unit
+ method select_global : Cil_types.varinfo -> unit
+ method view : GTree.view
+ method reset : unit -> t
+end
+
+module MAKE(TREE:sig type t
+ val sons: t -> t array
+ val custom_value: Gobject.g_type -> t -> column:int -> Gobject.basic
+ val column_list:GTree.column_list
+ end) =
+struct
+ type custom_tree =
+ {finfo: TREE.t;
+ mutable sons: custom_tree array;
+ mutable parent: custom_tree option;
+ fidx: int (* invariant: parent.(fidx)==myself *) }
+
+ let inbound i a = i>=0 && i<Array.length a
+
+ (** The custom model itself *)
+ class custom_tree_class column_list =
+ object(self)
+ inherit
+ [custom_tree,custom_tree,unit,unit] GTree.custom_tree_model column_list as parent
+
+ method custom_encode_iter cr = cr, (), ()
+ method custom_decode_iter cr () () = cr
+
+ val mutable num_roots : int = 0
+ val mutable roots : custom_tree array = [||]
+
+ method custom_get_iter (path:Gtk.tree_path) : custom_tree option =
+ let indices: int array = GTree.Path.get_indices path in
+ match indices with
+ | [||] ->
+ None
+ | _ ->
+ if inbound indices.(0) roots then
+ let result = ref (roots.(indices.(0))) in
+ try
+ for depth=1 to Array.length indices - 1 do
+ let index = indices.(depth) in
+ if inbound index !result.sons then
+ result:=!result.sons.(index)
+ else raise Not_found
+ done;
+ Some !result
+ with Not_found ->
+ None
+ else None
+
+ method custom_get_path (row:custom_tree) : Gtk.tree_path =
+ let current_row = ref row in
+ let path = ref [] in
+ while !current_row.parent <> None do
+ path := !current_row.fidx::!path;
+ current_row := match !current_row.parent with Some p -> p
+ | None -> assert false
+ done;
+ GTree.Path.create ((!current_row.fidx)::!path)
+
+ method custom_value (t:Gobject.g_type) (row:custom_tree) ~column =
+ TREE.custom_value t row.finfo ~column
+
+ method custom_iter_next (row:custom_tree) : custom_tree option =
+ let nidx = succ row.fidx in
+ match row.parent with
+ | None -> if inbound nidx roots then Some roots.(nidx)
+ else None
+ | Some parent ->
+ if inbound nidx parent.sons then
+ Some parent.sons.(nidx)
+ else None
+
+ method custom_iter_children (rowopt:custom_tree option) :custom_tree option =
+ match rowopt with
+ | None -> if inbound 0 roots then Some roots.(0) else None
+ | Some row -> if inbound 0 row.sons then Some row.sons.(0) else None
+
+ method custom_iter_has_child (row:custom_tree) : bool =
+ Array.length row.sons > 0
+
+ method custom_iter_n_children (rowopt:custom_tree option) : int =
+ match rowopt with
+ | None -> Array.length roots
+ | Some row -> Array.length row.sons
+
+ method custom_iter_nth_child (rowopt:custom_tree option) (n:int)
+ : custom_tree option =
+ match rowopt with
+ | None when inbound n roots -> Some roots.(n)
+ | Some row when inbound n row.sons -> Some (row.sons.(n))
+ | _ -> None
+
+ method custom_iter_parent (row:custom_tree) : custom_tree option =
+ row.parent
+
+ method custom_foreach f =
+ let f p _ = f p (match self#custom_get_iter p with
+ | Some v -> v
+ | None -> assert false)
+ in
+ parent#foreach f
+
+ method append_tree (t:TREE.t) =
+ let rec make_forest root sons =
+ Array.mapi
+ (fun i t -> let result = {finfo=t; fidx=i; parent = Some root;
+ sons = [||] }
+ in
+ let sons = make_forest result (TREE.sons t) in
+ result.sons<-sons;
+ result)
+ sons
+ in
+ let pos = num_roots in
+ num_roots <- num_roots+1;
+ let root = { finfo = t; sons = [||];
+ parent = None;
+ fidx = pos }
+ in
+
+ let sons = make_forest root (TREE.sons t)
+ in
+ root.sons <- sons;
+ roots <-
+ Array.init num_roots (fun n -> if n = num_roots - 1 then root
+ else roots.(n))
+ end
+
+ let custom_tree () =
+ new custom_tree_class TREE.column_list
+end
+
+module MYTREE = struct
+type storage = { mutable name : string;
+ mutable globals: global array;
+ mutable strikethrough: bool;
+ mutable visible: bool }
+
+
+type t = File of storage*t list | Global of storage
+
+let sons t = match t with
+| File (_,s) -> Array.of_list s
+| Global _ -> [||]
+
+let get_storage t = match t with
+| File (s,_) -> s
+| Global s -> s
+
+let default_storage s globals =
+ {
+ name = s;
+ globals = globals;
+ strikethrough = false;
+ visible = true
+ }
+
+ (* Set up the columns *)
+let column_list = new GTree.column_list
+let filename_col = column_list#add Gobject.Data.string
+let (glob_col:global list GTree.column) = column_list#add Gobject.Data.caml
+let strikethrough_col = column_list#add Gobject.Data.boolean
+let visible_col = column_list#add Gobject.Data.boolean
+
+let custom_value _ t ~column =
+ match column with
+ | 0 -> (* filename_col *) `STRING (Some (get_storage t).name)
+ | 1 -> (* glob_col *) `CAML (Obj.repr ((get_storage t).globals))
+ | 2 -> (* strikethrough_col *) `BOOL (get_storage t).strikethrough
+ | 3 -> (* visible_col *) `BOOL (get_storage t).visible
+ | _ -> assert false
+
+let make_file fname : t =
+ let globs = Globals.FileIndex.find fname in
+ let storage = default_storage fname (Array.of_list globs) in
+ let sons = List.fold_left
+ (fun acc glob -> match glob with
+ | GFun ({svar={vname=name}},_) ->
+ (Global(default_storage name [|glob|]))::acc
+ | _ -> acc)
+ []
+ globs
+ in
+ File (storage,sons)
+
+end
+
+module MODEL=MAKE(MYTREE)
+
+let rec make (tree_view:GTree.view) =
+
+ (** Model Part *)
+
+ let treestore = MODEL.custom_tree () in
+
+ (** Let's fill the model with all files. *)
+ List.iter
+ (fun s -> treestore#append_tree (MYTREE.make_file s))
+ (List.sort Pervasives.compare (Globals.FileIndex.get_files ()));
+
+ (** Let's build the table from cil standard types to rows in the model *)
+
+ (** These tables contain the path (in the treeview of file names)
+ to the global (reps. filename) *)
+ let global_path_tbl = Cilutil.VarinfoHashtbl.create 17 in
+ let file_path_tbl = Hashtbl.create 17 in
+
+ let cache path row =
+ (match row.MODEL.finfo with
+ | MYTREE.File (storage,_) ->
+ Hashtbl.add file_path_tbl storage.MYTREE.name (path,row)
+ | MYTREE.Global storage ->
+ let vi =
+ match storage.MYTREE.globals with
+ | [| GFun ({svar=vi},_) |] -> vi
+ | _ -> assert false
+ in
+ Cilutil.VarinfoHashtbl.add global_path_tbl vi (path,row));
+ false
+ in
+ treestore#custom_foreach cache;
+
+
+ let model_filtered = GTree.model_filter (treestore:>GTree.model) in
+ model_filtered#set_visible_column MYTREE.visible_col;
+
+ (** View part *)
+ let source_column = GTree.view_column ~title:"Source file" () in
+ let str_renderer = GTree.cell_renderer_text [] in
+ source_column#pack str_renderer;
+ source_column#add_attribute str_renderer "text" MYTREE.filename_col;
+ source_column#add_attribute str_renderer "strikethrough" MYTREE.strikethrough_col;
+
+ let _ = tree_view#append_column source_column in
+
+ tree_view#set_model (Some (model_filtered:>GTree.model));
+
+ let set_row ?strikethrough ?visible ?text (path,raw_row) =
+ let row = raw_row.MODEL.finfo in
+ may
+ (fun b -> (MYTREE.get_storage row).MYTREE.visible<- b )
+ visible;
+ may
+ (fun b -> (MYTREE.get_storage row).MYTREE.strikethrough <- b )
+ strikethrough;
+ may
+ (fun b -> (MYTREE.get_storage row).MYTREE.name <- b )
+ text;
+ treestore#custom_row_changed path raw_row
+
+ in
+ let set_file_attribute ?strikethrough ?visible ?text filename =
+ set_row ?strikethrough ?visible ?text
+ (Hashtbl.find file_path_tbl filename)
+ in
+ let set_global_attribute ?strikethrough ?visible ?text global =
+ set_row ?strikethrough ?visible ?text
+ (Cilutil.VarinfoHashtbl.find global_path_tbl global)
+ in
+ let myself = object
+
+ val mutable select_functions = []
+
+ method view = tree_view
+ method model = model_filtered
+ method get_select_functions = select_functions
+ method set_file_attribute = set_file_attribute
+ method set_global_attribute = set_global_attribute
+ method set_row_attribute = set_row
+ method reset () =
+ (** Cleanup the existing tree view *)
+ tree_view#set_model None;
+ (try
+ ignore (tree_view#remove_column (tree_view#get_column 0));
+ ignore (tree_view#remove_column (tree_view#get_column 0))
+ with Gpointer.Null -> ());
+ let myself = make tree_view in
+ List.iter myself#add_select_function select_functions;
+ myself
+
+ val mutable activated_path = "" (* prevent double selection *)
+ method enable_select_functions =
+ let select path deactivating =
+ let fail e = Format.eprintf
+ "selector handler got an internal error, please report: %s@."
+ (Printexc.to_string e)
+ in
+ try
+ if !Gtk_helper.gui_unlocked then
+ let path_s = GTree.Path.to_string path in
+ let was_activated = activated_path = path_s in
+ if not was_activated && not deactivating then
+ activated_path <- path_s;
+ let {MODEL.finfo=t} =
+ match treestore#custom_get_iter path with
+ | Some s ->s | None -> assert false
+ in
+ let globs = (MYTREE.get_storage t).MYTREE.globals in
+ (* prerr_endline
+ ("Select function "
+ ^ (if (not deactivating) then "true" else "false")
+ ^ " on "^path_s);*)
+ let globs = Array.to_list globs in
+ List.iter
+ (fun f ->
+ try
+ f ~was_activated ~activating:(not deactivating) globs
+ with e -> fail e)
+ select_functions;
+ true
+ else false
+ with e ->
+ Format.eprintf "gui could not select row in filetree, please \
+report: %s@."
+ (Printexc.to_string e);
+ true
+ in
+ tree_view#selection#set_select_function select
+
+ method add_select_function f =
+ select_functions <- select_functions@[f];
+
+ method select_global vi =
+ try
+ let path =
+ fst (Cilutil.VarinfoHashtbl.find global_path_tbl vi)
+ in
+ expand_to_path tree_view path;
+ tree_view#selection#select_path path
+ with Not_found -> ()
+ end
+ in
+ myself#enable_select_functions;
+ (myself:>t)
+
+
+(*
+Local Variables:
+compile-command: "LC_ALL=C make -C ../.. -j"
+End:
+*)
diff --git a/src/gui/filetree.ml b/src/gui/filetree_default.ml
similarity index 94%
rename from src/gui/filetree.ml
rename to src/gui/filetree_default.ml
index b7c85d0f777..f284a7a39e9 100644
--- a/src/gui/filetree.ml
+++ b/src/gui/filetree_default.ml
@@ -31,16 +31,6 @@ open Pretty_source
open Gtk_helper
open Cilutil
-class type t = object
- method model : GTree.model_filter
- method set_file_attribute: ?strikethrough:bool -> ?visible:bool -> ?text:string -> string -> unit
- method set_global_attribute: ?strikethrough:bool -> ?visible:bool -> ?text:string -> Cil_types.varinfo -> unit
- method add_select_function :
- (was_activated:bool -> activating:bool -> Cil_types.global list -> unit) -> unit
- method select_global : Cil_types.varinfo -> unit
- method view : GTree.view
- method reset : unit -> t
-end
let rec make (tree_view:GTree.view) =
@@ -219,6 +209,7 @@ report: %s@."
myself#enable_select_functions;
(myself:>t)
+
(*
Local Variables:
compile-command: "LC_ALL=C make -C ../.. -j"
--
GitLab