open Rep_desc
let map_opt f = function
None -> None
| Some v -> Some (f v)
module C = Configwin
type attribute = {
mutable att_name : string ;
mutable att_code : string ;
}
let params_for_att a =
let param_name = C.string
~f: (fun s -> a.att_name <- s)
Rep_messages.name a.att_name
in
let param_code = C.string
~f: (fun s -> a.att_code <- s)
Rep_messages.code a.att_code
in
[param_name ; param_code]
let tag_attributes_param tag =
let f_string a = [ a.att_name ; a.att_code ] in
let f_edit a =
ignore (C.simple_get Rep_messages.edit (params_for_att a));
a
in
let f_add () =
let a = { att_name = "" ; att_code = "" } in
match C.simple_get Rep_messages.edit (params_for_att a) with
C.Return_cancel -> []
| C.Return_apply
| C.Return_ok -> [a]
in
let f_eq a1 a2 = a1.att_name = a2.att_name in
let p = C.list
~f: (fun atts ->
tag.atts <- List.map (fun a -> (a.att_name, a.att_code)) atts
)
~eq: f_eq
~edit: f_edit
~add: f_add
~titles: [ Rep_messages.name ; Rep_messages.code ]
Rep_messages.attributes
f_string
(List.map (fun (n,c) -> { att_name = n ; att_code = c}) tag.atts)
in
p
let dir = ref (Sys.getcwd ())
let find_first_child store it =
let p = store#get_path it in
let res = ref None in
store#foreach
(fun _ it ->
let parent = store#iter_parent it in
match parent with
None -> false
| Some itp ->
if store#get_path itp = p then (res := Some it; true) else false
);
!res
let find_iter_above store it =
let p = store#get_path it in
let res = ref None in
store#foreach
(fun path it ->
let rr = store#get_row_reference path in
store#iter_next it;
if store#get_path it = p then (res := Some rr; true) else false
);
!res
let find_iter_below store it =
if store#iter_next it then
Some (store#get_row_reference (store#get_path it))
else
None
let clipboard = ref (None : Rep_desc.report_ele option)
class file wlabel filename_opt =
let cols = new GTree.column_list in
let col_display = cols#add Gobject.Data.string in
let (col_data: Rep_desc.report_ele GTree.column) = cols#add Gobject.Data.caml in
let store = GTree.tree_store cols in
object(self)
inherit Rep_gui_base.file ~file: Rep_installation.glade_file ()
val mutable filename = filename_opt
val mutable report_params = []
val mutable report_header = ""
method save () =
match filename with
None -> self#save_as ()
| Some f ->
let report = self#build_report () in
Rep_io.store_report f report
method save_as () =
match GToolbox.select_file ~title: Rep_messages.open_file ~dir () with
None -> ()
| Some f ->
filename <- Some f;
wlabel#set_text (Filename.basename f);
self#save ()
method close () = true
method delete ?(cut=false) () =
match self#selected_rr with
None -> ()
| Some rr ->
let row = rr#iter in
match store#get ~row ~column: col_data with
Then _ | Else _ -> ()
| _ ->
match self#build_report_desc ~row () with
| [] -> ()
| rep_desc :: _ ->
if cut then clipboard := Some rep_desc;
ignore (store#remove rr#iter) ;
tv#selection#unselect_all ()
method copy () =
match self#selected_rr with
None -> ()
| Some rr ->
let row = rr#iter in
match self#build_report_desc ~row () with
rep_desc :: _ ->
clipboard := Some rep_desc
| [] -> ()
method paste () =
match !clipboard with
None -> ()
| Some ele ->
let rr = self#selected_rr in
match rr with
None ->
self#insert_rep_desc ele ;
tv#selection#unselect_all ()
| Some rr ->
match store#get ~row: rr#iter ~column: col_data with
Cond _ -> ()
| _ ->
self#insert_rep_desc ~parent: rr ele ;
tv#selection#unselect_all ()
method move_up () =
match self#selected_rr with
None -> ()
| Some rr ->
let row = rr#iter in
match store#get ~row ~column: col_data with
Then _ | Else _ -> ()
| _ ->
match find_iter_above store row with
None -> ()
| Some rr2 ->
let it1 = store#get_iter rr#path in
let it2 = rr2#iter in
ignore (store#swap it1 it2)
method move_down () =
match self#selected_rr with
None -> ()
| Some rr ->
let row = rr#iter in
match store#get ~row ~column: col_data with
Then _ | Else _ -> ()
| _ ->
match find_iter_below store row with
None -> ()
| Some rr2 ->
let it1 = store#get_iter rr#path in
let it2 = rr2#iter in
ignore (store#swap it1 it2)
method selected_rr =
match tv#selection#get_selected_rows with
| [] -> None
| path :: _ -> Some (store#get_row_reference path)
method private params_for_leaf leaf =
let param = C.string
~f: (fun s -> leaf.leaf <- s)
Rep_messages.fun_unit leaf.leaf
in
[param]
method private params_for_sub sub =
let param = C.string
~f: (fun s -> sub.sub_code <- s)
Rep_messages.code sub.sub_code
in
[param]
method private params_for_tag tag =
let param_tag = C.string
~f: (fun s -> tag.tag <- s)
Rep_messages.tag tag.tag
in
let param_atts = tag_attributes_param tag in
[param_tag ; param_atts]
method private params_for_mark mark =
let param_id = C.string
~f: (fun s -> mark.mark_id <- s)
Rep_messages.ocaml_id mark.mark_id
in
let param_name = C.string
~f: (fun s -> mark.mark_name <- s)
Rep_messages.name mark.mark_name
in
[param_id ; param_name]
method private params_for_list list =
let param_f = C.string
~f: (fun s -> list.f <- s)
Rep_messages.fun_unit list.f
in
let param_var = C.string
~f: (fun s -> list.var <- s)
Rep_messages.ocaml_id list.var
in
[param_var ; param_f]
method private params_for_cond cond =
let param = C.string
~f: (fun s -> cond.cond <- s)
Rep_messages.fun_unit cond.cond
in
[param]
method insert_in_selected ele =
match self#selected_rr with
None -> self#insert_rep_desc ele
| Some rr -> self#insert_rep_desc ~parent: rr ele
method insert_leaf () =
let leaf = { leaf = "" } in
match C.simple_get ~width: 500 Rep_messages.insert_leaf
(self#params_for_leaf leaf)
with
C.Return_ok -> self#insert_in_selected (Leaf leaf)
| _ -> ()
method insert_sub () =
let sub = { sub_code = "" } in
match C.simple_get ~width: 500 Rep_messages.insert_sub
(self#params_for_sub sub)
with
C.Return_ok -> self#insert_in_selected (Sub sub)
| _ -> ()
method insert_tag () =
let tag = { tag = "" ; atts = [] ; tag_subs = []} in
match C.simple_get ~width: 400 ~height: 300 Rep_messages.insert_tag
(self#params_for_tag tag)
with
C.Return_ok -> self#insert_in_selected (Tag tag)
| _ -> ()
method insert_mark () =
let mark = { mark_id = "" ; mark_name = ""} in
match C.simple_get ~width: 500 Rep_messages.insert_mark
(self#params_for_mark mark)
with
C.Return_ok -> self#insert_in_selected (Mark mark)
| _ -> ()
method insert_list () =
let list = { f = "" ; var = "" ; list_subs = []} in
match C.simple_get ~width: 500 Rep_messages.insert_list
(self#params_for_list list)
with
C.Return_ok -> self#insert_in_selected (List list)
| _ -> ()
method insert_cond () =
let cond = { cond = "" ; subs_then = [] ; subs_else = []} in
match C.simple_get ~width: 500 Rep_messages.insert_cond
(self#params_for_cond cond)
with
C.Return_ok -> self#insert_in_selected (Cond cond)
| _ -> ()
method edit_selected () =
match self#selected_rr with
None -> ()
| Some rr ->
let row = rr#iter in
match store#get ~row ~column: col_data with
Then _ | Else _ -> ()
| ele ->
let params =
match ele with
Leaf l -> self#params_for_leaf l
| Mark m -> self#params_for_mark m
| Tag t -> self#params_for_tag t
| List l -> self#params_for_list l
| Cond c -> self#params_for_cond c
| Sub s -> self#params_for_sub s
| Else _ | Then _ -> assert false
in
match params with
[] -> ()
| _ ->
match C.simple_get Rep_messages.edit_selected params
with
C.Return_ok ->
store#set ~row ~column: col_display (self#string_of_desc_ele ele);
| _ ->
()
method edit_params () =
let param = C.strings
~f: (fun l -> report_params <- l)
~add: (fun () ->
match GToolbox.input_string
Rep_messages.add_parameter
Rep_messages.name
with
None -> []
| Some s -> [s]
)
Rep_messages.parameters
report_params
in
ignore (C.simple_get Rep_messages.edit_params [param])
method edit_header () =
let param = C.text
~f: (fun s -> report_header <- s)
Rep_messages.header
report_header
in
ignore (C.simple_get Rep_messages.edit_header [param])
method string_of_desc_ele = function
Leaf l -> l.leaf
| Tag t ->
Printf.sprintf
"<%s %s>"
t.tag
(String.concat " "
(List.map
(fun (n,v) -> Printf.sprintf "%s=%s" n v)
t.atts
)
)
| List l -> Printf.sprintf "for %s in %s ()" l.var l.f
| Cond c -> Printf.sprintf "if %s ()" c.cond
| Sub s -> Printf.sprintf "sub: %s ()" s.sub_code
| Mark m -> Printf.sprintf "mark: id=%s name=%s" m.mark_id m.mark_name
| Then _ -> "then"
| Else _ -> "else"
method insert_rep_desc ?parent ?pos ele =
let row =
match pos with
None -> store#append ?parent: (map_opt (fun rr -> rr#iter) parent) ()
| Some pos -> store#insert ?parent: (map_opt (fun rr -> rr#iter) parent) pos
in
let iter_rr rr = store#get_row_reference (store#get_path rr) in
(
match parent with
None -> ()
| Some rr -> tv#expand_row rr#path
);
match ele with
Leaf l ->
store#set row col_display (self#string_of_desc_ele ele);
store#set row col_data (Leaf { leaf = l.leaf })
| Tag t ->
store#set row col_display (self#string_of_desc_ele ele);
store#set row col_data (Tag { t with tag_subs = [] });
List.iter (self#insert_rep_desc ~parent: (iter_rr row)) t.tag_subs
| List l ->
store#set row col_display (self#string_of_desc_ele ele);
store#set row col_data (List { l with list_subs = []});
List.iter (self#insert_rep_desc ~parent: (iter_rr row)) l.list_subs
| Cond c ->
store#set row col_display (self#string_of_desc_ele ele);
store#set row col_data (Cond {c with subs_then = [] ; subs_else = []});
self#insert_rep_desc ~parent: (iter_rr row) (Then c);
self#insert_rep_desc ~parent: (iter_rr row) (Else c)
| Sub s ->
store#set row col_display (self#string_of_desc_ele ele);
store#set row col_data (Sub { sub_code = s.sub_code })
| Mark m ->
store#set row col_display (self#string_of_desc_ele ele);
store#set row col_data (Mark { m with mark_id = m.mark_id })
| Then c ->
store#set row col_display (self#string_of_desc_ele ele);
store#set row col_data (Then {c with subs_then = [] ; subs_else = []});
List.iter (self#insert_rep_desc ~parent: (iter_rr row)) c.subs_then
| Else c ->
store#set row col_display (self#string_of_desc_ele ele);
store#set row col_data (Else {c with subs_then = [] ; subs_else = []});
List.iter (self#insert_rep_desc ~parent: (iter_rr row)) c.subs_else
method show_report report =
store#clear ();
report_header <- report.rep_header ;
report_params <- report.rep_params ;
List.iter self#insert_rep_desc report.rep_eles
method build_report () =
{ rep_header = report_header ;
rep_params = report_params ;
rep_eles = self#build_report_desc () ;
}
method get_children (it_opt : Gtk.tree_iter option) =
let first =
match it_opt with
None -> store#get_iter_first
| Some it ->
if store#iter_has_child it then
find_first_child store it
else
None
in
match first with
None -> []
| Some it ->
let rr it = store#get_row_reference (store#get_path it) in
let rec f acc it =
if store#iter_next it then
f (rr it :: acc) it
else
List.rev acc
in
f [rr it] it
method build_report_desc ?row () =
let rec build rr =
let it = rr#iter in
match store#get ~row: it ~column: col_data with
Leaf l -> Leaf { leaf = l.leaf }
| Tag t ->
let subs = List.map build (self#get_children (Some it)) in
Tag { t with tag_subs = subs }
| List l ->
let subs = List.map build (self#get_children (Some it)) in
List { l with list_subs = subs }
| Cond c ->
let (subs_then, subs_else) =
match self#get_children (Some it) with
rr_then :: rr_else :: _ ->
(List.map build (self#get_children (Some rr_then#iter)),
List.map build (self#get_children (Some rr_else#iter))
)
| _ -> ([], [])
in
Cond { c with subs_then = subs_then ; subs_else = subs_else ; }
| Sub s ->
Sub { sub_code = s.sub_code }
| Mark m ->
Mark { m with mark_id = m.mark_id }
| Then c ->
Cond { c with subs_else = [] ;
subs_then = List.map build (self#get_children (Some it)) }
| Else c ->
Cond { c with subs_then = [] ;
subs_else = List.map build (self#get_children (Some it)) }
in
match row with
None -> List.map build (self#get_children None)
| Some it -> [build (store#get_row_reference (store#get_path it))]
method load file =
try
let report = Rep_io.load_report file in
self#show_report report
with
Failure s ->
GToolbox.message_box ~title: Rep_messages.error
s
initializer
tv#set_model (Some (store :> GTree.model));
let col = GTree.view_column ()
~renderer:(GTree.cell_renderer_text [], ["text", col_display]) in
ignore (tv#append_column col);
match filename_opt with
None -> ()
| Some filename -> self#load filename
end
class gui files =
object(self)
inherit Rep_gui_base.gui ~file: Rep_installation.glade_file ()
val mutable file_boxes = []
method add_file_box f_opt =
let title =
match f_opt with
None -> "<no name>"
| Some s -> Filename.basename s
in
let label = GMisc.label ~text: title () in
let fb = new file label f_opt in
let eb = GBin.event_box () in
fb#reparent eb#coerce;
ignore(notebook#append_page ~tab_label: label#coerce eb#coerce);
file_boxes <- file_boxes @ [fb];
notebook#goto_page ((List.length file_boxes) - 1)
method active_file =
try
let n = notebook#current_page in
Some (List.nth file_boxes n)
with
_ -> None
method quit = toplevel#destroy
method about () =
GToolbox.message_box
Rep_messages.about
Rep_messages.software_about
method new_report () = self#add_file_box None
method close_current () =
match self#active_file with
None -> ()
| Some fb ->
if fb#close () then
ignore (notebook#remove_page notebook#current_page)
method open_report () =
match GToolbox.select_file ~title: Rep_messages.open_file ~dir () with
None -> ()
| Some f -> self#add_file_box (Some f)
method on_current f () =
match self#active_file with
None -> ()
| Some fb -> f fb
initializer
(
match files with
[] -> self#add_file_box None
| _ -> List.iter (fun s -> self#add_file_box (Some s)) files
);
let handlers =
[ "on_quit_activate", `Simple self#quit;
"on_about_activate",`Simple self#about;
"on_new_activate", `Simple self#new_report;
"on_open_activate", `Simple self#open_report;
"on_save_activate", `Simple (self#on_current (fun fb -> fb#save ())) ;
"on_save_as_activate", `Simple (self#on_current (fun fb -> fb#save_as ())) ;
"on_close_activate", `Simple self#close_current ;
"on_edit_report_params_activate", `Simple (self#on_current (fun fb -> fb#edit_params ())) ;
"on_edit_report_header_activate", `Simple (self#on_current (fun fb -> fb#edit_header ())) ;
"on_edit_selected_node_activate", `Simple (self#on_current (fun fb -> fb#edit_selected ())) ;
"on_cut_activate", `Simple (self#on_current (fun fb -> fb#delete ~cut: true ())) ;
"on_copy_activate", `Simple (self#on_current (fun fb -> fb#copy ())) ;
"on_paste_activate", `Simple (self#on_current (fun fb -> fb#paste ())) ;
"on_delete_activate", `Simple (self#on_current (fun fb -> fb#delete ~cut: false ())) ;
"on_move_up_activate", `Simple (self#on_current (fun fb -> fb#move_up ())) ;
"on_move_down_activate", `Simple (self#on_current (fun fb -> fb#move_down ())) ;
"on_mark_activate", `Simple (self#on_current (fun fb -> fb#insert_mark ())) ;
"on_leaf_activate", `Simple (self#on_current (fun fb -> fb#insert_leaf ())) ;
"on_list_activate", `Simple (self#on_current (fun fb -> fb#insert_list ())) ;
"on_cond_activate", `Simple (self#on_current (fun fb -> fb#insert_cond ())) ;
"on_tag_activate", `Simple (self#on_current (fun fb -> fb#insert_tag ())) ;
"on_sub_activate", `Simple (self#on_current (fun fb -> fb#insert_sub ())) ;
]
in
Glade.bind_handlers ~extra:handlers ~warn:true self#xml;
ignore(gui#connect#destroy GMain.Main.quit)
end