diff options
Diffstat (limited to 'otherlibs/labltk')
| -rw-r--r-- | otherlibs/labltk/support/camltkwrap.ml | 8 | ||||
| -rw-r--r-- | otherlibs/labltk/support/camltkwrap.mli | 116 | ||||
| -rw-r--r-- | otherlibs/labltk/support/tkwait.ml | 7 |
3 files changed, 67 insertions, 64 deletions
diff --git a/otherlibs/labltk/support/camltkwrap.ml b/otherlibs/labltk/support/camltkwrap.ml index 5afe864df..5b49b19f0 100644 --- a/otherlibs/labltk/support/camltkwrap.ml +++ b/otherlibs/labltk/support/camltkwrap.ml @@ -23,12 +23,12 @@ end module Protocol = struct open Widget include Protocol - + let opentk () = coe (opentk ()) let opentk_with_args args = coe (opentk_with_args args) let openTk ?display ?clas () = coe (openTk ?display ?clas ()) - let cCAMLtoTKwidget table w = + let cCAMLtoTKwidget table w = Widget.check_class w table; (* we need run time type check of widgets *) TkToken (Widget.name w) @@ -71,7 +71,7 @@ module Timer = struct let remove = remove end -(* +(* Not compiled in support -module Tkwait = Tkwait +module Tkwait = Tkwait *) diff --git a/otherlibs/labltk/support/camltkwrap.mli b/otherlibs/labltk/support/camltkwrap.mli index 9c9321c21..1af566d2c 100644 --- a/otherlibs/labltk/support/camltkwrap.mli +++ b/otherlibs/labltk/support/camltkwrap.mli @@ -16,13 +16,13 @@ module Widget : sig type widget = Widget.any Widget.widget (* widget is an abstract type *) - + val default_toplevel : widget (* [default_toplevel] is "." in Tk, the toplevel widget that is always existing during a Tk session. Destroying [default_toplevel] ends the main loop *) - + val atom : parent: widget -> name: string -> widget (* [atom parent name] returns the widget [parent.name]. The widget is not created. Only its name is returned. In a given parent, there may @@ -31,35 +31,35 @@ module Widget : sig with a known name. It doesn't add the widget to the internal tables of CamlTk. *) - + val name : widget -> string (* [name w] returns the name (tk "path") of a widget *) - + (*--*) (* The following functions are used internally. There is normally no need for them in users programs *) - + val known_class : widget -> string (* [known_class w] returns the class of a widget (e.g. toplevel, frame), as known by the CamlTk interface. Not equivalent to "winfo w" in Tk. *) - + val dummy : widget (* [dummy] is a widget used as context when we don't have any. It is *not* a real widget. *) - + val new_atom : parent: widget -> ?name: string -> string -> widget (* incompatible with the classic camltk *) val get_atom : string -> widget (* [get_atom path] returns the widget with Tk path [path] *) - + val remove : widget -> unit (* [remove w] removes widget from the internal tables *) - + (* Subtypes tables *) val widget_any_table : string list val widget_button_table : string list @@ -77,95 +77,95 @@ module Widget : sig val widget_scrollbar_table : string list val widget_text_table : string list val widget_toplevel_table : string list - + val chk_sub : string -> 'a list -> 'a -> unit val check_class : widget -> string list -> unit (* Widget subtyping *) - + exception IllegalWidgetType of string (* Raised when widget command applied illegally*) (* this function is not used, but introduced for the compatibility with labltk. useless for camltk users *) - val coe : 'a Widget.widget -> Widget.any Widget.widget + val coe : 'a Widget.widget -> Widget.any Widget.widget end module Protocol : sig open Widget - + (* Lower level interface *) exception TkError of string (* Raised by the communication functions *) - - val debug : bool ref + + val debug : bool ref (* When set to true, displays approximation of intermediate Tcl code *) - + type tkArgs = TkToken of string | TkTokenList of tkArgs list (* to be expanded *) | TkQuote of tkArgs (* mapped to Tcl list *) - - + + (* Misc *) external splitlist : string -> string list = "camltk_splitlist" - + val add_destroy_hook : (widget -> unit) -> unit - - + + (* Opening, closing, and mainloop *) val default_display : unit -> string - + val opentk : unit -> widget (* The basic initialization function. [opentk ()] parses automatically the command line options and use the tk related options in them - such as "-display localhost:0" to initialize Tk applications. + such as "-display localhost:0" to initialize Tk applications. Consult wish manpage about the supported options. *) - + val keywords : (string * Arg.spec * string) list (* Command line parsing specification for Arg.parse, which contains the standard Tcl/Tk command line options such as "-display" and "-name". These Tk command line options are used by opentk *) - + val opentk_with_args : string list -> widget - (* [opentk_with_args argv] invokes [opentk] with the tk related - command line options given by [argv] to the executable program. *) - + (* [opentk_with_args argv] invokes [opentk] with the tk related + command line options given by [argv] to the executable program. *) + val openTk : ?display:string -> ?clas:string -> unit -> widget (* [openTk ~display:display ~clas:clas ()] is equivalent to [opentk ["-display"; display; "-name"; clas]] *) - + (* Legacy opentk functions *) val openTkClass: string -> widget (* [openTkClass class] is equivalent to [opentk ["-name"; class]] *) val openTkDisplayClass: string -> string -> widget - (* [openTkDisplayClass disp class] is equivalent to + (* [openTkDisplayClass disp class] is equivalent to [opentk ["-display"; disp; "-name"; class]] *) - + val closeTk : unit -> unit - val finalizeTk : unit -> unit - (* Finalize tcl/tk before exiting. This function will be automatically + val finalizeTk : unit -> unit + (* Finalize tcl/tk before exiting. This function will be automatically called when you call [Pervasives.exit ()] *) - + val mainLoop : unit -> unit - - + + (* Direct evaluation of tcl code *) val tkEval : tkArgs array -> string - + val tkCommand : tkArgs array -> unit - + (* Returning a value from a Tcl callback *) val tkreturn: string -> unit - - + + (* Callbacks: this is private *) - + type cbid = Protocol.cbid - + type callback_buffer = string list (* Buffer for reading callback arguments *) - + val callback_naming_table : (cbid, callback_buffer -> unit) Hashtbl.t (* CAMLTK val callback_memo_table : (widget, cbid) Hashtbl.t *) val callback_memo_table : (widget, cbid) Hashtbl.t @@ -181,12 +181,12 @@ module Protocol : sig (* Clean up callbacks associated to widget. Must be used only when the Destroy event is bind by the user and masks the default Destroy event binding *) - + val cTKtoCAMLwidget : string -> widget val cCAMLtoTKwidget : string list -> widget -> tkArgs - + val register : string -> callback:(callback_buffer -> unit) -> unit - + (*-*) val prerr_cbid : cbid -> unit end @@ -194,12 +194,12 @@ end module Textvariable : sig open Widget open Protocol - + type textVariable = Textvariable.textVariable (* TextVariable is an abstract type *) - + val create : ?on: widget -> unit -> textVariable - (* Allocation of a textVariable with lifetime associated to widget + (* Allocation of a textVariable with lifetime associated to widget if a widget is specified *) val create_temporary : widget -> textVariable (* for backward compatibility @@ -211,22 +211,22 @@ module Textvariable : sig (* Reading the val of a textVariable *) val name : textVariable -> string (* Its tcl name *) - + val cCAMLtoTKtextVariable : textVariable -> tkArgs (* Internal conversion function *) - + val handle : textVariable -> (unit -> unit) -> unit (* Callbacks on variable modifications *) - + val coerce : string -> textVariable - + (*-*) val free : textVariable -> unit end module Fileevent : sig open Unix - + val add_fileinput : file_descr -> (unit -> unit) -> unit val remove_fileinput: file_descr -> unit val add_fileoutput : file_descr -> (unit -> unit) -> unit @@ -236,16 +236,16 @@ end module Timer : sig type t = Timer.t - + val add : int -> (unit -> unit) -> t val set : int -> (unit -> unit) -> unit val remove : t -> unit end -(* +(* Tkwait exists, but is not used in support module Tkwait : sig - val internal_tracevis : string -> string -> unit - val internal_tracedestroy : string -> string -> unit + val internal_tracevis : string -> Protocol.cbid -> unit + val internal_tracedestroy : string -> Protocol.cbid -> unit end *) diff --git a/otherlibs/labltk/support/tkwait.ml b/otherlibs/labltk/support/tkwait.ml index 2574928c0..97a0b0eb8 100644 --- a/otherlibs/labltk/support/tkwait.ml +++ b/otherlibs/labltk/support/tkwait.ml @@ -16,7 +16,10 @@ (* $Id$ *) -external internal_tracevis : string -> string -> unit +external internal_tracevis : string -> Protocol.cbid -> unit = "camltk_wait_vis" -external internal_tracedestroy : string -> string -> unit +;; + +external internal_tracedestroy : string -> Protocol.cbid -> unit = "camltk_wait_des" +;; |