--- /dev/null
+(* $Id$
+ * ----------------------------------------------------------------------
+ *
+ *)
+
+open Pxp_types
+open Pxp_document
+open Ds_context
+
+
+let get_dimension s =
+ let re = Str.regexp "\\([0-9]*\\(.[0-9]+\\)?\\)[ \t\n]*\\(px\\|cm\\|in\\|mm\\|pt\\)" in
+ if Str.string_match re s 0 then begin
+ let number = Str.matched_group 1 s in
+ let dim = Str.matched_group 3 s in
+ match dim with
+ "px" -> Tk.Pixels (int_of_float (float_of_string number))
+ | "cm" -> Tk.Centimeters (float_of_string number)
+ | "in" -> Tk.Inches (float_of_string number)
+ | "mm" -> Tk.Millimeters (float_of_string number)
+ | "pt" -> Tk.PrinterPoint (float_of_string number)
+ | _ -> assert false
+ end
+ else
+ failwith ("Bad dimension: " ^ s)
+;;
+
+
+class virtual shared =
+ object(self)
+
+ (* --- default_ext --- *)
+
+ val mutable node = (None : shared node option)
+
+ method clone = {< >}
+ method node =
+ match node with
+ None ->
+ assert false
+ | Some n -> n
+ method set_node n =
+ node <- Some n
+
+ (* --- shared attributes: color & font settings --- *)
+
+ val mutable fgcolor = (None : string option)
+ val mutable bgcolor = (None : string option)
+ val mutable font = (None : string option)
+
+ method fgcolor =
+ (* Get the foreground color: If there is a local value, return it;
+ * otherwise ask parent node
+ *)
+ match fgcolor with
+ Some c -> c
+ | None -> try self # node # parent # extension # fgcolor with
+ Not_found -> failwith "#fgcolor"
+
+ method bgcolor =
+ (* Get the background color: If there is a local value, return it;
+ * otherwise ask parent node
+ *)
+ match bgcolor with
+ Some c -> c
+ | None -> try self # node # parent # extension # bgcolor with
+ Not_found -> failwith "#bgcolor"
+
+ method font =
+ (* Get the current font: If there is a local value, return it;
+ * otherwise ask parent node
+ *)
+ match font with
+ Some c -> c
+ | None -> try self # node # parent # extension # font with
+ Not_found -> failwith "#font"
+
+ method private init_color_and_font =
+ let get_color n =
+ try
+ match self # node # attribute n with
+ Value v -> Some v
+ | Implied_value -> None
+ | _ -> assert false
+ with Not_found -> None in
+ fgcolor <- get_color "fgcolor";
+ bgcolor <- get_color "bgcolor";
+ font <- get_color "font"; (* sic! *)
+
+
+ method private bg_color_opt =
+ [ Tk.Background (Tk.NamedColor (self # bgcolor)) ]
+
+ method private fg_color_opt =
+ [ Tk.Foreground (Tk.NamedColor (self # fgcolor)) ]
+
+ method private font_opt =
+ [ Tk.Font (self # font) ]
+
+ (* --- virtual --- *)
+
+ method virtual prepare : shared Pxp_yacc.index -> unit
+ method virtual create_widget : Widget.widget -> context -> Widget.widget
+
+ method pack_opts = ( [] : Tk.options list )
+ method xstretchable = false
+ method ystretchable = false
+
+ method accept (c:context) = ()
+
+ method private get_mask =
+ (* find parent which is a mask *)
+ let rec search n =
+ match n # node_type with
+ T_element "mask" ->
+ n # extension
+ | T_element _ ->
+ search (n # parent)
+ | _ ->
+ assert false
+ in
+ search (self # node)
+
+
+ method private accept_mask (c:context) =
+ let rec iterate n =
+ n # extension # accept c;
+ List.iter iterate (n # sub_nodes)
+ in
+ iterate (self # get_mask # node)
+
+
+ method start_node_name =
+ (failwith "#start_node_name" : string)
+
+ (* --- debug --- *)
+
+ method private name =
+ let nt = self # node # node_type in
+ match nt with
+ T_element n -> n
+ | T_data -> "#PCDATA"
+ | _ -> assert false
+
+ end
+;;
+
+
+class default =
+ object (self)
+ inherit shared
+
+ method prepare idx =
+ self # init_color_and_font
+
+ method create_widget w c =
+ failwith "default # create_widget"
+ end
+;;
+
+
+let dummy_node = new element_impl (new default);;
+
+class application =
+ object (self)
+ inherit shared
+
+ val mutable start_node = dummy_node
+
+ method prepare idx =
+ (* prepare this node *)
+ self # init_color_and_font;
+ if fgcolor = None then fgcolor <- Some "black";
+ if bgcolor = None then bgcolor <- Some "white";
+ if font = None then font <- Some "fixed";
+ let start =
+ match self # node # attribute "start" with
+ Value v -> v
+ | _ -> assert false in
+ start_node <- (try idx # find start with
+ Not_found -> failwith "Start node not found");
+ (* iterate over the subtree *)
+ let rec iterate n =
+ n # extension # prepare idx;
+ List.iter iterate (n # sub_nodes)
+ in
+ List.iter iterate (self # node # sub_nodes)
+
+
+ method start_node_name =
+ match self # node # attribute "start" with
+ Value v -> v
+ | _ -> assert false
+
+ method create_widget w c =
+ start_node # extension # create_widget w c
+
+ method pack_opts =
+ start_node # extension # pack_opts
+ end
+;;
+
+
+class sequence =
+ object (self)
+ inherit shared
+
+ method prepare idx =
+ self # init_color_and_font;
+
+ method create_widget w c =
+ let node = List.hd (self # node # sub_nodes) in
+ node # extension # create_widget w c
+
+ method pack_opts =
+ let node = List.hd (self # node # sub_nodes) in
+ node # extension # pack_opts
+ end
+;;
+
+
+class vbox =
+ object (self)
+ inherit shared
+
+ val mutable att_halign = "left"
+
+ method prepare idx =
+ self # init_color_and_font;
+ match self # node # attribute "halign" with
+ Value v -> att_halign <- v
+ | _ -> assert false
+
+ method create_widget w c =
+ let f = Frame.create w (self # bg_color_opt) in
+ let nodes = self # node # sub_nodes in
+ let options =
+ match att_halign with
+ "left" -> [ Tk.Anchor Tk.W ]
+ | "right" -> [ Tk.Anchor Tk.E ]
+ | "center" -> [ Tk.Anchor Tk.Center ]
+ | _ -> assert false
+ in
+ List.iter
+ (fun n ->
+ let opts = n # extension # pack_opts in
+ let wdg = n # extension # create_widget f c in
+ Tk.pack [wdg] (options @ opts);
+ )
+ nodes;
+ f
+
+ method pack_opts =
+ match self # xstretchable, self # ystretchable with
+ true, false -> [ Tk.Fill Tk.Fill_X; (* Tk.Expand true *) ]
+ | false, true -> [ Tk.Fill Tk.Fill_Y; (* Tk.Expand true *) ]
+ | true, true -> [ Tk.Fill Tk.Fill_Both; (* Tk.Expand true *) ]
+ | false, false -> []
+
+ method xstretchable =
+ let nodes = self # node # sub_nodes in
+ List.exists (fun n -> n # extension # xstretchable) nodes
+
+ method ystretchable =
+ let nodes = self # node # sub_nodes in
+ List.exists (fun n -> n # extension # ystretchable) nodes
+
+ end
+
+;;
+
+
+class mask =
+ object (self)
+
+ inherit vbox
+
+ method prepare idx =
+ self # init_color_and_font;
+ att_halign <- "left"
+ end
+;;
+
+
+class hbox =
+ object (self)
+ inherit shared
+
+ val mutable att_width = None
+ val mutable att_halign = "left"
+ val mutable att_valign = "top"
+
+ method prepare idx =
+ self # init_color_and_font;
+ begin match self # node # attribute "halign" with
+ Value v -> att_halign <- v
+ | _ -> assert false
+ end;
+ begin match self # node # attribute "valign" with
+ Value v -> att_valign <- v
+ | _ -> assert false
+ end;
+ begin match self # node # attribute "width" with
+ Value v -> att_width <- Some (get_dimension v)
+ | Implied_value -> att_width <- None
+ | _ -> assert false
+ end
+
+ method create_widget w c =
+ let f1 = Frame.create w (self # bg_color_opt) in
+ let f_extra =
+ match att_width with
+ None -> []
+ | Some wd ->
+ [ Canvas.create f1
+ ( [ Tk.Width wd; Tk.Height (Tk.Pixels 0);
+ Tk.Relief Tk.Flat;
+ Tk.HighlightThickness (Tk.Pixels 0);
+ ] @
+ self # bg_color_opt ) ]
+ in
+ let f2 = Frame.create f1 (self # bg_color_opt) in
+ let nodes = self # node # sub_nodes in
+
+ let outer_pack_opts =
+ match att_halign with
+ "left" -> [ Tk.Anchor Tk.W ]
+ | "right" -> [ Tk.Anchor Tk.E ]
+ | "center" -> [ Tk.Anchor Tk.Center ]
+ | _ -> assert false
+ in
+ let inner_pack_opts =
+ match att_valign with
+ "top" -> [ Tk.Anchor Tk.N ]
+ | "bottom" -> [ Tk.Anchor Tk.S ]
+ | "center" -> [ Tk.Anchor Tk.Center ]
+ | _ -> assert false
+ in
+ List.iter
+ (fun n ->
+ let opts = n # extension # pack_opts in
+ let wdg = n # extension # create_widget f2 c in
+ Tk.pack [wdg] (inner_pack_opts @ [ Tk.Side Tk.Side_Left ] @ opts);
+ )
+ nodes;
+ let extra_opts = self # pack_opts in
+ Tk.pack (f_extra @ [f2]) (outer_pack_opts @ extra_opts);
+ f1
+
+ method pack_opts =
+ match self # xstretchable, self # ystretchable with
+ true, false -> [ Tk.Fill Tk.Fill_X; (* Tk.Expand true *) ]
+ | false, true -> [ Tk.Fill Tk.Fill_Y; (* Tk.Expand true *) ]
+ | true, true -> [ Tk.Fill Tk.Fill_Both; (* Tk.Expand true *) ]
+ | false, false -> []
+
+ method xstretchable =
+ let nodes = self # node # sub_nodes in
+ List.exists (fun n -> n # extension # xstretchable) nodes
+
+ method ystretchable =
+ let nodes = self # node # sub_nodes in
+ List.exists (fun n -> n # extension # ystretchable) nodes
+
+ end
+;;
+
+class vspace =
+ object (self)
+ inherit shared
+
+ val mutable att_height = Tk.Pixels 0
+ val mutable att_fill = false
+
+ method prepare idx =
+ self # init_color_and_font;
+ begin match self # node # attribute "height" with
+ Value v -> att_height <- get_dimension v
+ | _ -> assert false
+ end;
+ begin match self # node # attribute "fill" with
+ Value "yes" -> att_fill <- true
+ | Value "no" -> att_fill <- false
+ | _ -> assert false
+ end
+
+
+ method create_widget w c =
+ let f = Frame.create w ( self # bg_color_opt ) in
+ let strut =
+ Canvas.create f
+ ( [ Tk.Height att_height; Tk.Width (Tk.Pixels 0);
+ Tk.Relief Tk.Flat;
+ Tk.HighlightThickness (Tk.Pixels 0);
+ ] @
+ self # bg_color_opt ) in
+ if att_fill then
+ Tk.pack [strut] [Tk.Fill Tk.Fill_Y; Tk.Expand true]
+ else
+ Tk.pack [strut] [];
+ f
+
+ method pack_opts =
+ if att_fill then [ Tk.Fill Tk.Fill_Y; Tk.Expand true ] else []
+
+ method ystretchable = att_fill
+ end
+;;
+
+class hspace =
+ object (self)
+ inherit shared
+
+
+ val mutable att_width = Tk.Pixels 0
+ val mutable att_fill = false
+
+ method prepare idx =
+ self # init_color_and_font;
+ begin match self # node # attribute "width" with
+ Value v -> att_width <- get_dimension v
+ | _ -> assert false
+ end;
+ begin match self # node # attribute "fill" with
+ Value "yes" -> att_fill <- true
+ | Value "no" -> att_fill <- false
+ | _ -> assert false
+ end
+
+
+ method create_widget w c =
+ let f = Frame.create w ( self # bg_color_opt ) in
+ let strut =
+ Canvas.create f
+ ( [ Tk.Width att_width; Tk.Height (Tk.Pixels 0);
+ Tk.Relief Tk.Flat;
+ Tk.HighlightThickness (Tk.Pixels 0);
+ ] @
+ self # bg_color_opt ) in
+ if att_fill then
+ Tk.pack [strut] [Tk.Fill Tk.Fill_X; Tk.Expand true]
+ else
+ Tk.pack [strut] [];
+ f
+
+ method pack_opts =
+ if att_fill then [ Tk.Fill Tk.Fill_X; Tk.Expand true ] else []
+
+ method xstretchable = att_fill
+ end
+;;
+
+class label =
+ object (self)
+ inherit shared
+
+ val mutable att_textwidth = (-1)
+ val mutable att_halign = "left"
+
+ method prepare idx =
+ self # init_color_and_font;
+ att_textwidth <- (match self # node # attribute "textwidth" with
+ Value v ->
+ let w = try int_of_string v
+ with _ -> failwith ("Not an integer: " ^ v) in
+ w
+ | Implied_value ->
+ (-1)
+ | _ -> assert false);
+ att_halign <- (match self # node # attribute "halign" with
+ Value v -> v
+ | _ -> assert false);
+
+
+ method create_widget w c =
+ let opts_textwidth = if att_textwidth < 0 then [] else
+ [ Tk.TextWidth att_textwidth ] in
+ let opts_halign =
+ match att_halign with
+ "left" -> [ Tk.Anchor Tk.W ]
+ | "right" -> [ Tk.Anchor Tk.E ]
+ | "center" -> [ Tk.Anchor Tk.Center ]
+ | _ -> assert false
+ in
+ let opts_content =
+ [ Tk.Text (self # node # data) ] in
+ let label = Label.create w (opts_textwidth @ opts_halign @
+ opts_content @ self # bg_color_opt @
+ self # fg_color_opt @ self # font_opt) in
+ label
+
+ end
+;;
+
+class entry =
+ object (self)
+ inherit shared
+
+ val mutable tv = lazy (Textvariable.create())
+ val mutable att_textwidth = (-1)
+ val mutable att_slot = ""
+
+ method prepare idx =
+ self # init_color_and_font;
+ tv <- lazy (Textvariable.create());
+ att_textwidth <- (match self # node # attribute "textwidth" with
+ Value v ->
+ let w = try int_of_string v
+ with _ -> failwith ("Not an integer: " ^ v) in
+ w
+ | Implied_value ->
+ (-1)
+ | _ -> assert false);
+ att_slot <- (match self # node # attribute "slot" with
+ Value v -> v
+ | _ -> assert false);
+
+ method create_widget w c =
+ let opts_textwidth = if att_textwidth < 0 then [] else
+ [ Tk.TextWidth att_textwidth ] in
+ let e = Entry.create w ( [ Tk.TextVariable (Lazy.force tv) ] @
+ self # fg_color_opt @
+ self # bg_color_opt @
+ self # font_opt @
+ opts_textwidth
+ ) in
+ let s =
+ try c # get_slot att_slot with
+ Not_found -> self # node # data in
+ Textvariable.set (Lazy.force tv) s;
+ e
+
+ method accept c =
+ c # set_slot att_slot (Textvariable.get (Lazy.force tv))
+
+ end
+;;
+
+class textbox =
+ object (self)
+ inherit shared
+
+ val mutable att_textwidth = (-1)
+ val mutable att_textheight = (-1)
+ val mutable att_slot = ""
+ val mutable last_widget = None
+
+ method prepare idx =
+ self # init_color_and_font;
+ att_textwidth <- (match self # node # attribute "textwidth" with
+ Value v ->
+ let w = try int_of_string v
+ with _ -> failwith ("Not an integer: " ^ v) in
+ w
+ | Implied_value ->
+ (-1)
+ | _ -> assert false);
+ att_textheight <- (match self # node # attribute "textheight" with
+ Value v ->
+ let w = try int_of_string v
+ with _ -> failwith ("Not an integer: " ^ v) in
+ w
+ | Implied_value ->
+ (-1)
+ | _ -> assert false);
+ att_slot <- (match self # node # attribute "slot" with
+ Value v -> v
+ | Implied_value -> ""
+ | _ -> assert false);
+
+
+ method create_widget w c =
+ let opts_textwidth = if att_textwidth < 0 then [] else
+ [ Tk.TextWidth att_textwidth ] in
+ let opts_textheight = if att_textheight < 0 then [] else
+ [ Tk.TextHeight att_textheight ] in
+ let f = Frame.create w (self # bg_color_opt) in
+ let vscrbar = Scrollbar.create f [ Tk.Orient Tk.Vertical ] in
+ let e = Text.create f ( [ ] @
+ self # fg_color_opt @
+ self # bg_color_opt @
+ self # font_opt @
+ opts_textwidth @ opts_textheight
+ ) in
+ last_widget <- Some e;
+ Scrollbar.configure vscrbar [ Tk.ScrollCommand
+ (fun s -> Text.yview e s);
+ Tk.Width (Tk.Pixels 9) ];
+ Text.configure e [ Tk.YScrollCommand
+ (fun a b -> Scrollbar.set vscrbar a b) ];
+ let s =
+ if att_slot <> "" then
+ try c # get_slot att_slot with
+ Not_found -> self # node # data
+ else
+ self # node # data
+ in
+ (* Text.insert appends always a newline to the last line; so strip
+ * an existing newline first
+ *)
+ let s' =
+ if s <> "" & s.[String.length s - 1] = '\n' then
+ String.sub s 0 (String.length s - 1)
+ else
+ s in
+ Text.insert e (Tk.TextIndex(Tk.End,[])) s' [];
+ if att_slot = "" then
+ Text.configure e [ Tk.State Tk.Disabled ];
+ Tk.pack [e] [ Tk.Side Tk.Side_Left ];
+ Tk.pack [vscrbar] [ Tk.Side Tk.Side_Left; Tk.Fill Tk.Fill_Y ];
+ f
+
+ method accept c =
+ if att_slot <> "" then
+ match last_widget with
+ None -> ()
+ | Some w ->
+ let s =
+ Text.get
+ w
+ (Tk.TextIndex(Tk.LineChar(1,0),[]))
+ (Tk.TextIndex(Tk.End,[])) in
+ c # set_slot att_slot s
+
+ end
+;;
+
+class button =
+ object (self)
+ inherit shared
+
+ val mutable att_label = ""
+ val mutable att_action = ""
+ val mutable att_goto = ""
+
+ method prepare idx =
+ self # init_color_and_font;
+ att_label <- (match self # node # attribute "label" with
+ Value v -> v
+ | _ -> assert false);
+ att_action <- (match self # node # attribute "action" with
+ Value v -> v
+ | _ -> assert false);
+ att_goto <- (match self # node # attribute "goto" with
+ Value v -> v
+ | Implied_value -> ""
+ | _ -> assert false);
+ if att_action = "goto" then begin
+ try let _ = idx # find att_goto in () with
+ Not_found -> failwith ("Target `" ^ att_goto ^ "' not found")
+ end;
+ if att_action = "list-prev" or att_action = "list-next" then begin
+ let m = self # get_mask in
+ if m # node # parent # node_type <> T_element "sequence" then
+ failwith ("action " ^ att_action ^ " must not be used out of <sequence>");
+ end;
+
+
+ method create_widget w c =
+ let cmd () =
+ self # accept_mask c;
+ match att_action with
+ "goto" ->
+ c # goto att_goto
+ | "save" ->
+ c # save_obj
+ | "exit" ->
+ Protocol.closeTk()
+ | "save-exit" ->
+ c # save_obj;
+ Protocol.closeTk()
+ | "list-prev" ->
+ let m = self # get_mask # node in
+ let s = m # parent in
+ let rec search l =
+ match l with
+ x :: y :: l' ->
+ if y == m then
+ match x # attribute "name" with
+ Value s -> c # goto s
+ | _ -> assert false
+ else
+ search (y :: l')
+ | _ -> ()
+ in
+ search (s # sub_nodes)
+ | "list-next" ->
+ let m = self # get_mask # node in
+ let s = m # parent in
+ let rec search l =
+ match l with
+ x :: y :: l' ->
+ if x == m then
+ match y # attribute "name" with
+ Value s -> c # goto s
+ | _ -> assert false
+ else
+ search (y :: l')
+ | _ -> ()
+ in
+ search (s # sub_nodes)
+ | "hist-prev" ->
+ (try c # previous with Not_found -> ())
+ | "hist-next" ->
+ (try c # next with Not_found -> ())
+ | _ -> ()
+ in
+ let b = Button.create w ( [ Tk.Text att_label; Tk.Command cmd ] @
+ self # fg_color_opt @
+ self # bg_color_opt @
+ self # font_opt ) in
+ b
+
+
+ end
+;;
+
+
+(**********************************************************************)
+
+open Pxp_yacc
+
+let tag_map =
+ make_spec_from_mapping
+ ~data_exemplar:(new data_impl (new default))
+ ~default_element_exemplar:(new element_impl (new default))
+ ~element_mapping:
+ (let m = Hashtbl.create 50 in
+ Hashtbl.add m "application"
+ (new element_impl (new application));
+ Hashtbl.add m "sequence"
+ (new element_impl (new sequence));
+ Hashtbl.add m "mask"
+ (new element_impl (new mask));
+ Hashtbl.add m "vbox"
+ (new element_impl (new vbox));
+ Hashtbl.add m "hbox"
+ (new element_impl (new hbox));
+ Hashtbl.add m "vspace"
+ (new element_impl (new vspace));
+ Hashtbl.add m "hspace"
+ (new element_impl (new hspace));
+ Hashtbl.add m "label"
+ (new element_impl (new label));
+ Hashtbl.add m "entry"
+ (new element_impl (new entry));
+ Hashtbl.add m "textbox"
+ (new element_impl (new textbox));
+ Hashtbl.add m "button"
+ (new element_impl (new button));
+ m)
+ ()
+;;
+
+(* ======================================================================
+ * History:
+ *
+ * $Log$
+ * Revision 1.1 2000/11/17 09:57:31 lpadovan
+ * Initial revision
+ *
+ * Revision 1.5 2000/08/30 15:58:49 gerd
+ * Updated.
+ *
+ * Revision 1.4 2000/07/16 19:36:03 gerd
+ * Updated.
+ *
+ * Revision 1.3 2000/07/08 22:03:11 gerd
+ * Updates because of PXP interface changes.
+ *
+ * Revision 1.2 2000/06/04 20:29:19 gerd
+ * Updates because of renamed PXP modules.
+ *
+ * Revision 1.1 1999/08/21 19:11:05 gerd
+ * Initial revision.
+ *
+ *
+ *)
projects / helm.git / blobdiff