Re: [Caml-list] Adding ttk (tile tk) bindings to labltk

[Jacques Garrigue <garrigue@math.nagoya-u.ac.jp>]

[-- Attachment #1: Type: text/plain, Size: 1589 bytes --]

On 2013/10/04, at 9:24, Eliot Handelman <eliot@colba.net> wrote:

> On 10/03/2013 05:45 AM, Tim Cuthbertson wrote:
>> 
>> Does anyone know if it's possible to add ttk widgets to labltk? Is there a library other than labltk that I should be using for ttk?
> 
> It is for me -- here's how I got  LabelFrame going:
> 
> open Tk
> open Protocol
> 
> let tokenize strings =
>  Arr.of_list (L1.map (fun s -> TkToken s) strings)
> 
> let tk_command string_list =
>   Protocol.tkCommand (tokenize string_list)
> 
> let tk_eval string_list  =
>  Protocol.tkEval (tokenize string_list)
> 
> let after ms =
>  tk_command [ "after"; string_of_int ms]
> 
> module LabelFrame = struct
>  let id = ref 0
>  let create ?(text = "") top =
>    let i = int !id in
>      incr id;
>      let lf_name = (Widget.name top) ^ ".labelframe" ^ i in
>    tk_command
>      ["ttk::labelframe"; lf_name;
>       "-text"; text
>      ];
>    Protocol.cTKtoCAMLwidget lf_name
> end
> 
> best,

This code could easily be generated by tkcompiler (i.e. adding it to WIdget.src),
but for the use of :: inside the name, as it isn't a valid ocaml name.
The simplest is probably to slightly modify tkcompiler to handle namespaces.

[…]
Well I tried that approach, and at this point it's rather painful.
The additions to Widget.src are minimal, but the widget types are hardcoded,
so you end up by having to modify more things than you should.
A bit of refactoring would solve that.

	Jacques Garrigue

Here is the patch to just to modify tkcompiler and add ttk_labelframe.


[-- Attachment #2: ttk_labelframe.diff --]
[-- Type: application/octet-stream, Size: 17046 bytes --]

diff --git a/Widgets.src b/Widgets.src
index e662682..8f8b50f 100644
--- a/Widgets.src
+++ b/Widgets.src
@@ -2302,3 +2302,11 @@ module Encoding {
   function () system_set ["encoding"; "system"; string]
   function (string) system_get ["encoding"; "system"]
 }
+
+% ttk::labelframe
+widget "ttk::labelframe" {
+  function (string) after [int]
+}
+subtype option("ttk::labelframe") {
+  Text
+}
diff --git a/camltk/modules b/camltk/modules
index f9fabde..6f5e521 100644
--- a/camltk/modules
+++ b/camltk/modules
@@ -1,5 +1,5 @@
-CWIDGETOBJS= cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo
-cBell.ml cScale.ml cWinfo.ml cScrollbar.ml cEntry.ml cListbox.ml cWm.ml cTkwait.ml cGrab.ml cFont.ml cCanvas.ml cImage.ml cClipboard.ml cLabel.ml cResource.ml cMessage.ml cText.ml cImagephoto.ml cOption.ml cFrame.ml cSelection.ml cDialog.ml cPlace.ml cPixmap.ml cMenubutton.ml cRadiobutton.ml cFocus.ml cPack.ml cImagebitmap.ml cEncoding.ml cOptionmenu.ml cCheckbutton.ml cTkvars.ml cPalette.ml cMenu.ml cButton.ml cToplevel.ml cGrid.ml : _tkgen.ml
+CWIDGETOBJS= cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cTtk_labelframe.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo
+cBell.ml cScale.ml cWinfo.ml cScrollbar.ml cEntry.ml cListbox.ml cWm.ml cTkwait.ml cGrab.ml cFont.ml cCanvas.ml cImage.ml cClipboard.ml cLabel.ml cResource.ml cMessage.ml cText.ml cImagephoto.ml cOption.ml cFrame.ml cSelection.ml cDialog.ml cPlace.ml cTtk_labelframe.ml cPixmap.ml cMenubutton.ml cRadiobutton.ml cFocus.ml cPack.ml cImagebitmap.ml cEncoding.ml cOptionmenu.ml cCheckbutton.ml cTkvars.ml cPalette.ml cMenu.ml cButton.ml cToplevel.ml cGrid.ml : _tkgen.ml
 
 cBell.cmo : cBell.ml
 cBell.cmi : cBell.mli
@@ -47,6 +47,8 @@ cDialog.cmo : cDialog.ml
 cDialog.cmi : cDialog.mli
 cPlace.cmo : cPlace.ml
 cPlace.cmi : cPlace.mli
+cTtk_labelframe.cmo : cTtk_labelframe.ml
+cTtk_labelframe.cmi : cTtk_labelframe.mli
 cPixmap.cmo : cPixmap.ml
 cPixmap.cmi : cPixmap.mli
 cMenubutton.cmo : cMenubutton.ml
@@ -77,4 +79,4 @@ cToplevel.cmo : cToplevel.ml
 cToplevel.cmi : cToplevel.mli
 cGrid.cmo : cGrid.ml
 cGrid.cmi : cGrid.mli
-camltk.cmo : cTk.cmo cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo 
+camltk.cmo : cTk.cmo cBell.cmo cScale.cmo cWinfo.cmo cScrollbar.cmo cEntry.cmo cListbox.cmo cWm.cmo cTkwait.cmo cGrab.cmo cFont.cmo cCanvas.cmo cImage.cmo cClipboard.cmo cLabel.cmo cResource.cmo cMessage.cmo cText.cmo cImagephoto.cmo cOption.cmo cFrame.cmo cSelection.cmo cDialog.cmo cPlace.cmo cTtk_labelframe.cmo cPixmap.cmo cMenubutton.cmo cRadiobutton.cmo cFocus.cmo cPack.cmo cImagebitmap.cmo cEncoding.cmo cOptionmenu.cmo cCheckbutton.cmo cTkvars.cmo cPalette.cmo cMenu.cmo cButton.cmo cToplevel.cmo cGrid.cmo 
diff --git a/compiler/compile.ml b/compiler/compile.ml
index 029cce7..18c95ab 100644
--- a/compiler/compile.ml
+++ b/compiler/compile.ml
@@ -80,6 +80,15 @@ let count ~item:x l =
   List.iter ~f:(fun y -> if x = y then incr count) l;
   !count
 
+let caml_name s =
+  let b = Buffer.create (String.length s) in
+  for i = 0 to String.length s - 1 do
+    let c = s.[i] in
+    if c <> ':' then Buffer.add_char b c
+    else if i > 0 && s.[i-1] = ':' then Buffer.add_char b '_'
+  done;
+  Buffer.contents b
+
 (* Extract all types from a template *)
 let rec types_of_template = function
     StringArg _ -> []
@@ -108,10 +117,10 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
   | String -> "string"
 (* new *)
   | List (Subtype (sup, sub)) ->
-    if !Flags.camltk then "(* " ^ sub ^ " *) " ^ sup ^ " list"
+    if !Flags.camltk then "(* " ^ sub ^ " *) " ^ caml_name sup ^ " list"
     else begin
       if return then
-        sub ^ "_" ^ sup ^ " list"
+        caml_name sub ^ "_" ^ caml_name sup ^ " list"
       else begin
          try
           let typdef = Hashtbl.find types_table sup in
@@ -145,7 +154,8 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
       String.concat ~sep:" * "
         (List.map tyl ~f:(fun (l, t) -> typelabel l ^ ppMLtype t))
   | Subtype ("widget", sub) ->
-      if !Flags.camltk then "(* " ^ sub ^" *) widget" else sub ^ " widget"
+      if !Flags.camltk then "(* " ^ sub ^" *) widget" else
+      caml_name sub ^ " widget"
   | UserDefined "widget" ->
       if !Flags.camltk then "widget"
       else begin
@@ -182,7 +192,8 @@ let ppMLtype ?(any=false) ?(return=false) ?(def=false) ?(counter=ref 0) =
         with Not_found -> s
       end
   | Subtype (s, s') ->
-      if !Flags.camltk then "(* " ^ s' ^ " *) " ^ s else s' ^ "_" ^ s
+      if !Flags.camltk then "(* " ^ s' ^ " *) " ^ caml_name s else
+      caml_name s' ^ "_" ^ caml_name s
   | Function (Product tyl) ->
         raise (Failure "Function (Product tyl) ? ppMLtype")
   | Function (Record tyl) ->
@@ -300,13 +311,13 @@ let camltk_write_type ~intf:w ~impl:w' name ~def:typdef =
       (sort_components typdef.constructors);
     w "\n\n";
     (* The set of all constructors *)
-    w' ("let "^name^"_any_table = [");
+    w' ("let "^caml_name name^"_any_table = [");
     write_constructor_set ~w:w' ~sep:"; "
       (sort_components typdef.constructors);
     w' ("]\n\n");
     (* The subset of constructors for each subtype *)
     List.iter ~f:(function (s,l) ->
-      w' ("let "^name^"_"^s^"_table = [");
+      w' ("let "^caml_name name^"_"^caml_name s^"_table = [");
       write_constructor_set ~w:w' ~sep:"; " (sort_components l);
       w' ("]\n\n"))
       typdef.subtypes
@@ -576,7 +587,7 @@ let rec converterCAMLtoTK ~context_widget argname ty =
  |  Subtype ("widget", s') ->
        if !Flags.camltk then
          let name = "cCAMLtoTKwidget " in
-         let args = "widget_"^s'^"_table "^argname in
+         let args = "widget_"^caml_name s'^"_table "^argname in
          let args =
            if requires_widget_context "widget" then
              context_widget^" "^args
@@ -584,7 +595,7 @@ let rec converterCAMLtoTK ~context_widget argname ty =
          name^args
        else begin
          let name = "cCAMLtoTKwidget " in
-         let args = "(" ^ argname ^ " : " ^ s' ^ " widget)" in
+         let args = "(" ^ argname ^ " : " ^ caml_name s' ^ " widget)" in
          name ^ args
        end
  |  Subtype (s, s') ->
@@ -594,9 +605,10 @@ let rec converterCAMLtoTK ~context_widget argname ty =
        in
        let args =
          if !Flags.camltk then begin
-           s^"_"^s'^"_table "^argname
+           caml_name s^"_"^caml_name s'^"_table "^argname
          end else begin
-           if safetype then "(" ^ argname ^ " : [< " ^ s' ^ "_" ^ s ^ "])"
+           if safetype then
+             "(" ^ argname ^ " : [< " ^ caml_name s' ^ "_" ^ caml_name s ^ "])"
            else argname
          end
        in
@@ -842,7 +854,7 @@ let rec write_result_parsing ~w = function
       | MultipleToken -> w (converterTKtoCAML ~arg:"(splitlist res)" ty)
 
 let labltk_write_function ~w def =
-  w ("let " ^ def.ml_name);
+  w ("let " ^ caml_name def.ml_name);
   (* a bit approximative *)
   let context_widget = match def.template with
     ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1"
@@ -891,7 +903,7 @@ let labltk_write_function ~w def =
   w "\n\n"
 
 let camltk_write_function ~w def =
-  w ("let " ^ def.ml_name);
+  w ("let " ^ caml_name def.ml_name);
   (* a bit approximative *)
   let context_widget = match def.template with
     ListArg (TypeArg(_, UserDefined("widget")) :: _) -> "v1"
@@ -969,8 +981,9 @@ let write_function ~w def =
 ;;
 
 let labltk_write_create ~w clas =
+  let oclas = caml_name clas in
   w ("let create ?name =\n");
-  w ("  " ^ clas ^ "_options_optionals (fun opts parent ->\n");
+  w ("  " ^ oclas ^ "_options_optionals (fun opts parent ->\n");
   w ("     let w = new_atom \"" ^ clas ^ "\" ~parent ?name in\n");
   w  "     tkCommand [|";
   w ("TkToken \"" ^ clas ^ "\";\n");
@@ -1044,7 +1057,8 @@ let write_catch_optionals ~w clas ~def:typdef =
   if typdef.subtypes = [] then () else
   List.iter typdef.subtypes ~f:
   begin fun (subclass, classdefs) ->
-    w  ("let " ^ subclass ^ "_" ^ clas ^ "_optionals f = fun\n");
+    w  ("let " ^ caml_name subclass ^ "_" ^ caml_name clas ^
+        "_optionals f = fun\n");
     let tklabels = List.map ~f:gettklabel classdefs in
     let l =
       List.map classdefs ~f:
@@ -1062,7 +1076,7 @@ let write_catch_optionals ~w clas ~def:typdef =
     let v =
       List.map l ~f:
         begin fun (si, s) ->
-          "(maycons ccCAMLtoTK" ^ clas ^ "_" ^ s ^ " " ^ si
+          "(maycons ccCAMLtoTK" ^ caml_name clas ^ "_" ^ caml_name s ^ " " ^ si
         end in
     w (String.concat ~sep:"\n" p);
     w " ->\n";
diff --git a/compiler/intf.ml b/compiler/intf.ml
index 42ad1b3..7f92259 100644
--- a/compiler/intf.ml
+++ b/compiler/intf.ml
@@ -49,7 +49,7 @@ let labltk_write_create_p ~w wname =
           end))
     with Not_found -> fatal_error "in write_create_p"
   end;
-  w (" ->\n  'a widget -> " ^ wname ^ " widget\n");
+  w (" ->\n  'a widget -> " ^ caml_name wname ^ " widget\n");
   w "(** [create ?name parent options...] creates a new widget with\n";
   w "    parent [parent] and new patch component [name], if specified. *)\n\n"
 ;;
diff --git a/compiler/maincompile.ml b/compiler/maincompile.ml
index 74b144d..7b370a2 100644
--- a/compiler/maincompile.ml
+++ b/compiler/maincompile.ml
@@ -166,6 +166,7 @@ let option_hack oc =
 
 let realname name =
   (* module name fix for camltk *)
+  let name = caml_name name in
   if !Flags.camltk then "c" ^ String.capitalize name
   else name
 ;;
@@ -290,7 +291,7 @@ let compile () =
     Hashtbl.iter (fun name _ ->
       let cname = realname name in
       output_string oc (Printf.sprintf "module %s = %s;;\n"
-                          (String.capitalize name)
+                          (String.capitalize (caml_name name))
                           (String.capitalize cname))) module_table;
     close_out oc
   end else begin
@@ -311,13 +312,14 @@ module Timer = Timer;;\n\
     Hashtbl.iter (fun name _ ->
       let cname = realname name in
       output_string oc (Printf.sprintf "module %s = %s;;\n"
-                          (String.capitalize name)
+                          (String.capitalize (caml_name name))
                           (String.capitalize cname))) module_table;
     (* widget typer *)
     output_string oc "\n(** Widget typers *)\n\nopen Widget\n\n";
     Hashtbl.iter (fun name def ->
       match def.module_type with
       | Widget ->
+          let name = caml_name name in
           output_string oc (Printf.sprintf
               "let %s (w : any widget) =\n" name);
           output_string oc (Printf.sprintf
diff --git a/compiler/parser.mly b/compiler/parser.mly
index 6dc7aff..0471273 100644
--- a/compiler/parser.mly
+++ b/compiler/parser.mly
@@ -306,7 +306,12 @@ ParserArity :
   { MultipleToken }
 ;
 
-
+ModuleName :
+   IDENT
+  { $1 }
+ | STRING
+  { $1 }
+;
 
 entry :
   TYPE ParserArity TypeName LBRACE Constructors RBRACE
@@ -315,15 +320,15 @@ entry :
     { enter_type $4 $3 $6 ~variant: true }
 | TYPE ParserArity TypeName EXTERNAL
     { enter_external_type $3 $2 }
-| SUBTYPE ParserArity OPTION LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE
+| SUBTYPE ParserArity OPTION LPAREN ModuleName RPAREN LBRACE AbbrevConstructors RBRACE
     { enter_subtype "options" $2 $5 $8 }
 | SUBTYPE ParserArity TypeName LPAREN IDENT RPAREN LBRACE AbbrevConstructors RBRACE
     { enter_subtype $3 $2 $5 $8 }
 | Command
     { enter_function $1 }
-| WIDGET IDENT LBRACE WidgetComponents RBRACE
+| WIDGET ModuleName LBRACE WidgetComponents RBRACE
     { enter_widget $2 $4 }
-| MODULE IDENT LBRACE ModuleComponents RBRACE
+| MODULE ModuleName LBRACE ModuleComponents RBRACE
     { enter_module (String.uncapitalize $2) $4 }
 | EOF
     { raise End_of_file }
diff --git a/labltk/modules b/labltk/modules
index 6298817..aafadae 100644
--- a/labltk/modules
+++ b/labltk/modules
@@ -1,5 +1,5 @@
-WIDGETOBJS= bell.cmo scale.cmo winfo.cmo scrollbar.cmo entry.cmo listbox.cmo wm.cmo tkwait.cmo grab.cmo font.cmo canvas.cmo image.cmo clipboard.cmo label.cmo message.cmo text.cmo imagephoto.cmo option.cmo frame.cmo selection.cmo dialog.cmo place.cmo pixmap.cmo menubutton.cmo radiobutton.cmo focus.cmo pack.cmo imagebitmap.cmo encoding.cmo optionmenu.cmo checkbutton.cmo tkvars.cmo palette.cmo menu.cmo button.cmo toplevel.cmo grid.cmo
-bell.ml scale.ml winfo.ml scrollbar.ml entry.ml listbox.ml wm.ml tkwait.ml grab.ml font.ml canvas.ml image.ml clipboard.ml label.ml message.ml text.ml imagephoto.ml option.ml frame.ml selection.ml dialog.ml place.ml pixmap.ml menubutton.ml radiobutton.ml focus.ml pack.ml imagebitmap.ml encoding.ml optionmenu.ml checkbutton.ml tkvars.ml palette.ml menu.ml button.ml toplevel.ml grid.ml : _tkgen.ml
+WIDGETOBJS= bell.cmo scale.cmo winfo.cmo scrollbar.cmo entry.cmo listbox.cmo wm.cmo tkwait.cmo grab.cmo font.cmo canvas.cmo image.cmo clipboard.cmo label.cmo message.cmo text.cmo imagephoto.cmo option.cmo frame.cmo selection.cmo dialog.cmo place.cmo ttk_labelframe.cmo pixmap.cmo menubutton.cmo radiobutton.cmo focus.cmo pack.cmo imagebitmap.cmo encoding.cmo optionmenu.cmo checkbutton.cmo tkvars.cmo palette.cmo menu.cmo button.cmo toplevel.cmo grid.cmo
+bell.ml scale.ml winfo.ml scrollbar.ml entry.ml listbox.ml wm.ml tkwait.ml grab.ml font.ml canvas.ml image.ml clipboard.ml label.ml message.ml text.ml imagephoto.ml option.ml frame.ml selection.ml dialog.ml place.ml ttk_labelframe.ml pixmap.ml menubutton.ml radiobutton.ml focus.ml pack.ml imagebitmap.ml encoding.ml optionmenu.ml checkbutton.ml tkvars.ml palette.ml menu.ml button.ml toplevel.ml grid.ml : _tkgen.ml
 
 bell.cmo : bell.ml
 bell.cmi : bell.mli
@@ -45,6 +45,8 @@ dialog.cmo : dialog.ml
 dialog.cmi : dialog.mli
 place.cmo : place.ml
 place.cmi : place.mli
+ttk_labelframe.cmo : ttk_labelframe.ml
+ttk_labelframe.cmi : ttk_labelframe.mli
 pixmap.cmo : pixmap.ml
 pixmap.cmi : pixmap.mli
 menubutton.cmo : menubutton.ml
diff --git a/support/rawwidget.ml b/support/rawwidget.ml
index d4344ad..48d4a0c 100644
--- a/support/rawwidget.ml
+++ b/support/rawwidget.ml
@@ -47,6 +47,7 @@ and scale
 and scrollbar
 and text
 and toplevel
+and ttk_labelframe
 
 let forget_type w = (Obj.magic (w : 'a raw_widget) : raw_any raw_widget)
 let coe = forget_type
@@ -122,6 +123,7 @@ and widget_scale_table = [ "scale" ]
 and widget_scrollbar_table = [ "scrollbar" ]
 and widget_text_table = [ "text" ]
 and widget_toplevel_table = [ "toplevel" ]
+and widget_ttk_labelframe_table = [ "ttk::labelframe" ]
 
 let new_suffix clas n =
   try
diff --git a/support/rawwidget.mli b/support/rawwidget.mli
index e9f82ef..c9ac895 100644
--- a/support/rawwidget.mli
+++ b/support/rawwidget.mli
@@ -37,6 +37,7 @@ and scale
 and scrollbar
 and text
 and toplevel
+and ttk_labelframe
 
 val forget_type : 'a raw_widget -> raw_any raw_widget
 val coe : 'a raw_widget -> raw_any raw_widget
@@ -100,6 +101,7 @@ val widget_scale_table : string list
 val widget_scrollbar_table : string list
 val widget_text_table : string list
 val widget_toplevel_table : string list
+val widget_ttk_labelframe_table : string list
 
 val chk_sub : string -> 'a list -> 'a -> unit
 val check_class : 'a raw_widget -> string list -> unit
diff --git a/support/widget.mli b/support/widget.mli
index 7761f2f..9d85050 100644
--- a/support/widget.mli
+++ b/support/widget.mli
@@ -37,6 +37,7 @@ and scale
 and scrollbar
 and text
 and toplevel
+and ttk_labelframe
 
 val forget_type : 'a widget -> any widget
 val coe : 'a widget -> any widget
@@ -100,6 +101,7 @@ val widget_scale_table : string list
 val widget_scrollbar_table : string list
 val widget_text_table : string list
 val widget_toplevel_table : string list
+val widget_ttk_labelframe_table : string list
 
 val chk_sub : string -> 'a list -> 'a -> unit
 val check_class : 'a widget -> string list -> unit