%(***********************************************************************)

%(*                                                                     *)

%(*                 MLTk, Tcl/Tk interface of OCaml                     *)

%(*                                                                     *)

%(*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)

%(*               projet Cristal, INRIA Rocquencourt                    *)

%(*            Jacques Garrigue, Kyoto University RIMS                  *)

%(*                                                                     *)

%(*  Copyright 2002 Institut National de Recherche en Informatique et   *)

%(*  en Automatique and Kyoto University.  All rights reserved.         *)

%(*  This file is distributed under the terms of the GNU Library        *)

%(*  General Public License, with the special exception on linking      *)

%(*  described in file LICENSE found in the OCaml source tree.          *)

%(*                                                                     *)

%(***********************************************************************)

%%%%%%%%%%%%%% Standard Tk8.0.3 Widgets and functions %%%%%%%%%%%%%%

type Widget external

% cget will probably never be implemented with verifications

function (string) cgets [widget; "cget"; string]

% another version with some hack is

type options_constrs external

function (string) cget [widget; "cget"; options_constrs]

% constructors of type options_constrs are of the form C<c>

% where <c> is an option constructor  (e.g. CBackground)

%%%%% Some types for standard options of widgets

type Anchor {

    NW ["nw"]       N ["n"]           NE ["ne"]

    W  ["w"]   Center ["center"]      E  ["e"]

    SW ["sw"]       S ["s"]           SE ["se"]

}

type Bitmap external    % builtin_GetBitmap.ml

type Cursor external    % builtin_GetCursor.ml

type Color external     % builtin_GetCursor.ml

##ifdef CAMLTK

type ImageBitmap {

  BitmapImage [string]

  }

type ImagePhoto {

  PhotoImage [string]

  }

##else

variant type ImageBitmap {

  Bitmap [string]

  }

variant type ImagePhoto {

  Photo [string]

  }

variant type Image {

  Bitmap [string]

  Photo [string]

}

##endif

type Justification {

   Justify_Left   ["left"]

   Justify_Center ["center"]

   Justify_Right  ["right"]

}

type Orientation {

    Vertical ["vertical"]

    Horizontal ["horizontal"]

}

type Relief {

   Raised ["raised"]

   Sunken ["sunken"]

   Flat   ["flat"]

   Ridge  ["ridge"]

   Solid  ["solid"]

   Groove ["groove"]

}

type TextVariable external      % textvariable.ml

type Units external             % builtin_GetPixel.ml

%%%%% The standard options, as defined in man page options(n)

%%%%% The subtype is never used

subtype option(standard) {

   ActiveBackground             ["-activebackground"; Color]

   ActiveBorderWidth            ["-activeborderwidth"; Units/int]

   ActiveForeground             ["-activeforeground"; Color]

   Anchor                       ["-anchor"; Anchor]

   Background                   ["-background"; Color]

   Bitmap                       ["-bitmap"; Bitmap]

   BorderWidth                  ["-borderwidth"; Units/int]

   Cursor                       ["-cursor";  Cursor]

   DisabledForeground           ["-disabledforeground"; Color]

   ExportSelection              ["-exportselection"; bool]

   Font                         ["-font"; string]

   Foreground                   ["-foreground"; Color]

% Geometry is not one of standard options...

   Geometry                     ["-geometry"; string]  % Too variable to encode

   HighlightBackground          ["-highlightbackground"; Color]

   HighlightColor               ["-highlightcolor"; Color]

   HighlightThickness           ["-highlightthickness"; Units/int]

##ifdef CAMLTK

   % images are split, to do additionnal static typing

   ImageBitmap (ImageBitmap)    ["-image"; ImageBitmap]

   ImagePhoto  (ImagePhoto)    ["-image"; ImagePhoto]

##else

   Image                        ["-image"; Image]

##endif

   InsertBackground             ["-insertbackground"; Color]

   InsertBorderWidth            ["-insertborderwidth"; Units/int]

   InsertOffTime                ["-insertofftime"; int]   % Positive only

   InsertOnTime                 ["-insertontime"; int]    % Idem

   InsertWidth                  ["-insertwidth"; Units/int]

   Jump                         ["-jump"; bool]

   Justify                      ["-justify"; Justification]

   Orient                       ["-orient"; Orientation]

   PadX                         ["-padx"; Units/int]

   PadY                         ["-pady"; Units/int]

   Relief                       ["-relief"; Relief]

   RepeatDelay                  ["-repeatdelay"; int]

   RepeatInterval               ["-repeatinterval"; int]

   SelectBackground             ["-selectbackground"; Color]

   SelectBorderWidth            ["-selectborderwidth"; Units/int]

   SelectForeground             ["-selectforeground"; Color]

   SetGrid                      ["-setgrid"; bool]

   % incomplete description of TakeFocus

   TakeFocus                    ["-takefocus"; bool]

   Text                         ["-text"; string]

   TextVariable                 ["-textvariable"; TextVariable]

   TroughColor                  ["-troughcolor"; Color]

   UnderlinedChar               ["-underline"; int]

   WrapLength                   ["-wraplength"; Units/int]

   XScrollCommand               ["-xscrollcommand"; function(first:float, last:float)]

   YScrollCommand               ["-yscrollcommand"; function(first:float, last:float)]

}

%%%% Some other common types

type Index external   % builtin_index.ml

type sequence ScrollValue external   % builtin_ScrollValue.ml

% type sequence ScrollValue {

%   MoveTo ["moveto"; float]

%   ScrollUnit ["scroll"; int; "unit"]

%   ScrollPage ["scroll"; int; "page"]

%   }

%%%%% bell(n)

module Bell {

##ifdef CAMLTK

  function () ring ["bell"; ?displayof:["-displayof"; widget]]

  function () ring_displayof ["bell"; "-displayof" ; displayof: widget]

##else

  function () ring ["bell"; ?displayof:["-displayof"; widget]]

##endif

  }

%%%%% bind(n)

% builtin_bind.ml

%%%%% bindtags(n)

%type Bindings {

%   TagBindings [string]

%   WidgetBindings [widget]

%   }

type Bindings external

function () bindtags ["bindtags"; widget; [bindings: Bindings list]]

function (Bindings list) bindtags_get ["bindtags"; widget]

%%%%% bitmap(n)

subtype option(bitmapimage) {

  Background

  Data ["-data"; string]

  File ["-file"; string]

  Foreground

  Maskdata ["-maskdata"; string]

  Maskfile ["-maskfile"; string]

  }

module Imagebitmap {

  function (ImageBitmap) create ["image"; "create"; "bitmap"; ?name:[ImageBitmap]; option(bitmapimage) list]

##ifdef CAMLTK

  function (ImageBitmap) create_named ["image"; "create"; "bitmap"; ImageBitmap; option(bitmapimage) list]

##endif

  function () delete ["image"; "delete"; ImageBitmap]

  function (int) height ["image"; "height"; ImageBitmap]

  function (int) width ["image"; "width"; ImageBitmap]

  function () configure [ImageBitmap; "configure"; option(bitmapimage) list]

  function (string) configure_get [ImageBitmap; "configure"]

  % Functions inherited from the "image" TK class

  }

%%%%% button(n)

type State {

   Normal ["normal"]

   Active ["active"]

   Disabled ["disabled"]

   Hidden ["hidden"]                           % introduced in tk8.3, requested for Syndex

}

widget button {

   % Standard options

   option ActiveBackground

   option ActiveForeground

   option Anchor

   option Background

   option Bitmap

   option BorderWidth

   option Cursor

   option DisabledForeground

   option Font

   option Foreground

   option HighlightBackground

   option HighlightColor

   option HighlightThickness

##ifdef CAMLTK

   option ImageBitmap

   option ImagePhoto

##else

   option Image

##endif

   option Justify

   option PadX

   option PadY

   option Relief

   option TakeFocus

   option Text

   option TextVariable

   option UnderlinedChar

   option WrapLength

   % Widget specific options

   option Command ["-command"; function ()]

   option Default ["-default"; State]

   option Height ["-height"; Units/int]

   option State ["-state"; State]

   option Width ["-width"; Units/int]

   function ()  configure [widget(button); "configure"; option(button) list]

   function (string) configure_get [widget(button); "configure"]

   function () flash [widget(button); "flash"]

   function () invoke [widget(button); "invoke"]

   }

%%%%%% canvas(n)

% Item ids and tags

type TagOrId {

  Tag [string]

  Id  [int]

}

% Indices: defined internally

% subtype Index(canvas) {

%   Number End Insert SelFirst SelLast AtXY

%   }

type SearchSpec {

  Above ["above"; TagOrId]

  All   ["all"]

  Below ["below"; TagOrId]

  Closest ["closest"; Units/int; Units/int]

  ClosestHalo (Closesthalo) ["closest"; Units/int; Units/int; Units/int]

  ClosestHaloStart (Closesthalostart) ["closest"; Units/int; Units/int; Units/int; TagOrId]

  Enclosed ["enclosed"; Units/int;Units/int;Units/int;Units/int]

  Overlapping ["overlapping"; int;int;int;int]

  Withtag ["withtag"; TagOrId]

}

type ColorMode {

   Color ["color"]

   Gray ["gray"]

   Mono ["mono"]

}

subtype option(postscript) {

   % Cannot support this without array variables

   % Colormap ["-colormap"; TextVariable]

   Colormode ["-colormode"; ColorMode]

   File ["-file"; string]

   % Fontmap ["-fontmap"; TextVariable]

   Height

   PageAnchor ["-pageanchor"; Anchor]

   PageHeight ["-pageheight"; Units/int]

   PageWidth ["-pagewidth"; Units/int]

   PageX ["-pagex"; Units/int]

   PageY ["-pagey"; Units/int]

   Rotate ["-rotate"; bool]

   Width

   X ["-x"; Units/int]

   Y ["-y"; Units/int]

   }

% Arc item configuration

type ArcStyle {

   Arc ["arc"]

   Chord ["chord"]

   PieSlice ["pieslice"]

}

subtype option(arc) {

   Extent ["-extent"; float]

   Dash ["-dash"; string]

   % Fill is used by packer

   FillColor ["-fill"; Color]

   Outline ["-outline"; Color]

   OutlineStipple ["-outlinestipple"; Bitmap]

   Start ["-start"; float]

   Stipple ["-stipple"; Bitmap]

   ArcStyle ["-style"; ArcStyle]

   Tags ["-tags"; [TagOrId/string list]]

   Width

  }

% Bitmap item configuration

subtype option(bitmap) {

   Anchor

   Background

   Bitmap

   Foreground

   Tags

}

% Image item configuration

subtype option(image) {

   Anchor

##ifdef CAMLTK

   ImagePhoto

   ImageBitmap

##else

   Image

##endif

   Tags

}

% Line item configuration

type ArrowStyle {

   Arrow_None ["none"]

   Arrow_First ["first"]

   Arrow_Last ["last"]

   Arrow_Both ["both"]

}

type CapStyle {

   Cap_Butt ["butt"]

   Cap_Projecting ["projecting"]

   Cap_Round ["round"]

}

type JoinStyle {

   Join_Bevel ["bevel"]

   Join_Miter ["miter"]

   Join_Round ["round"]

}

subtype option(line) {

   ArrowStyle ["-arrow"; ArrowStyle]

   ArrowShape ["-arrowshape"; [Units/int; Units/int; Units/int]]

   CapStyle ["-capstyle"; CapStyle]

   Dash

   FillColor

   JoinStyle ["-joinstyle"; JoinStyle]

   Smooth ["-smooth"; bool]

   SplineSteps ["-splinesteps"; int]

   Stipple

   Tags

   Width

   }

% Oval item configuration

subtype option(oval) {

   Dash FillColor Outline Stipple Tags Width

   }

% Polygon item configuration

subtype option(polygon) {

   Dash FillColor Outline Smooth SplineSteps

   Stipple Tags Width

   }

% Rectangle item configuration

subtype option(rectangle) {

   Dash FillColor Outline Stipple Tags Width

   }

% Text item configuration

##ifndef CAMLTK

% Only for Labltk. CanvasTextState is unified as State in Camltk

type CanvasTextState {

   Normal ["normal"]

   Disabled ["disabled"]

   Hidden ["hidden"]

}

##endif

subtype option(canvastext) {

   Anchor FillColor Font Justify

   Stipple Tags Text Width

##ifdef CAMLTK

   State                                       % introduced in tk8.3, requested for Syndex

##else

   CanvasTextState ["-state"; CanvasTextState] % introduced in tk8.3, requested for Syndex

##endif

   }

% Window item configuration

subtype option(window) {

   Anchor Height Tags Width

   Window ["-window"; widget]

   Dash

   }

% Types of items

type CanvasItem {

   Arc_item ["arc"]

   Bitmap_item ["bitmap"]

   Image_item ["image"]

   Line_item ["line"]

   Oval_item ["oval"]

   Polygon_item ["polygon"]

   Rectangle_item ["rectangle"]

   Text_item ["text"]

   Window_item ["window"]

   User_item [string]

}

widget canvas {

   % Standard options

   option Background

   option BorderWidth

   option Cursor

   option HighlightBackground

   option HighlightColor

   option HighlightThickness

   option InsertBackground

   option InsertBorderWidth

   option InsertOffTime

   option InsertOnTime

   option InsertWidth

   option Relief

   option SelectBackground

   option SelectBorderWidth

   option SelectForeground

   option TakeFocus

   option XScrollCommand

   option YScrollCommand

   % Widget specific options

   option CloseEnough ["-closeenough"; float]

   option Confine ["-confine"; bool]

   option Height ["-height"; Units/int]

   option ScrollRegion ["-scrollregion"; [Units/int;Units/int;Units/int;Units/int]]

   option Width ["-width"; Units/int]

   option XScrollIncrement ["-xscrollincrement"; Units/int]

   option YScrollIncrement ["-yscrollincrement"; Units/int]

   function () addtag [widget(canvas); "addtag"; tag: TagOrId/string; specs: SearchSpec list]     % Tag only

   % bbox not fully supported. should be builtin because of ambiguous result

   % will raise Protocol.TkError if no items match TagOrId

   function (int,int,int,int) bbox [widget(canvas); "bbox"; TagOrId list]

   external bind "builtin/canvas_bind"

##ifdef CAMLTK

   function (float) canvasx [widget(canvas); "canvasx"; ?spacing:[Units]; Units]

   function (float) canvasy [widget(canvas); "canvasy"; ?spacing:[Units]; Units]

   function (float) canvasx_grid [widget(canvas); "canvasx"; Units; Units]

   function (float) canvasy_grid [widget(canvas); "canvasy"; Units; Units]

##else

   function (float) canvasx [widget(canvas); "canvasx"; x:int; ?spacing:[int]]

   function (float) canvasy [widget(canvas); "canvasy"; y:int; ?spacing:[int]]

##endif

   function () configure [widget(canvas); "configure"; option(canvas) list]

   function (string) configure_get [widget(canvas); "configure"]

   % TODO: check result

   function (float list) coords_get [widget(canvas); "coords"; TagOrId]

##ifdef CAMLTK

   function () coords_set [widget(canvas); "coords"; TagOrId; xys: Units list]

##else

   function () coords_set [widget(canvas); "coords"; TagOrId; xys: {int, int} list]

##endif

   % create variations (see below)

   function () dchars [widget(canvas); "dchars"; TagOrId; first: Index(canvas); last: Index(canvas)]

   function () delete [widget(canvas); "delete"; TagOrId list]

   function () dtag [widget(canvas); "dtag"; TagOrId; tag: TagOrId/string]

   function (TagOrId list) find [widget(canvas); "find"; specs: SearchSpec list]

   % focus variations

   function () focus_reset [widget(canvas); "focus"; ""]

   function (TagOrId) focus_get [widget(canvas); "focus"]

   function () focus [widget(canvas); "focus"; TagOrId]

   function (TagOrId/string list) gettags [widget(canvas); "gettags"; TagOrId]

   function () icursor [widget(canvas); "icursor"; TagOrId; index: Index(canvas)]

   function (int) index [widget(canvas); "index"; TagOrId; index: Index(canvas)]

   function () insert [widget(canvas); "insert"; TagOrId; before: Index(canvas); text: string]

   % itemcget, itemconfigure are defined later

   function () lower [widget(canvas); "lower"; TagOrId; ?below: [TagOrId]]

##ifdef CAMLTK

   function () lower_below [widget(canvas); "lower"; TagOrId; TagOrId]

   function () lower_bot   [widget(canvas); "lower"; TagOrId]

##endif

   function () move [widget(canvas); "move"; TagOrId; x: Units/int; y: Units/int]

   unsafe function (string) postscript [widget(canvas); "postscript"; option(postscript) list]

   % We use raise with Module name

   function () raise [widget(canvas); "raise"; TagOrId; ?above:[TagOrId]]

##ifdef CAMLTK

   function () raise_above [widget(canvas); "raise"; TagOrId; TagOrId]

   function () raise_top [widget(canvas); "raise"; TagOrId]

##endif

   function () scale [widget(canvas); "scale"; TagOrId; xorigin: Units/int; yorigin: Units/int; xscale: float; yscale: float]

   % For scan, use x:int and y:int since common usage is with mouse coordinates

   function () scan_mark [widget(canvas); "scan"; "mark"; x: int; y: int]

   function () scan_dragto [widget(canvas); "scan"; "dragto"; x: int; y: int]

   % select variations

   function () select_adjust [widget(canvas); "select"; "adjust"; TagOrId; index: Index(canvas)]

   function () select_clear [widget(canvas); "select"; "clear"]

   function () select_from [widget(canvas); "select"; "from"; TagOrId; index: Index(canvas)]

   function (TagOrId) select_item [widget(canvas); "select"; "item"]

   function () select_to  [widget(canvas); "select"; "to"; TagOrId; index: Index(canvas)]

   function (CanvasItem) typeof [widget(canvas); "type"; TagOrId]

   function (float,float) xview_get [widget(canvas); "xview"]

   function (float,float) yview_get [widget(canvas); "yview"]

   function () xview [widget(canvas); "xview"; scroll: ScrollValue]

   function () yview [widget(canvas); "yview"; scroll: ScrollValue]

   % create and configure variations

   function (TagOrId) create_arc [widget(canvas); "create"; "arc"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(arc) list]

   function (TagOrId) create_bitmap [widget(canvas); "create"; "bitmap"; x: Units/int; y: Units/int; option(bitmap) list]

   function (TagOrId) create_image [widget(canvas); "create"; "image"; x: Units/int; y: Units/int; option(image) list]

##ifdef CAMLTK

   function (TagOrId) create_line [widget(canvas); "create"; "line"; Units list; option(line) list]

   function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; Units list; option(polygon) list]

##else

   function (TagOrId) create_line [widget(canvas); "create"; "line"; xys: {int, int} list; option(line) list]

   function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; xys: {int, int} list; option(polygon) list]

##endif

   function (TagOrId) create_oval [widget(canvas); "create"; "oval"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(oval) list]

   function (TagOrId) create_rectangle [widget(canvas); "create"; "rectangle"; x1: Units/int; y1: Units/int; x2: Units/int; y2: Units/int; option(rectangle) list]

   function (TagOrId) create_text [widget(canvas); "create"; "text"; x: Units/int; y: Units/int; option(canvastext) list]

   function (TagOrId) create_window [widget(canvas); "create"; "window"; x: Units/int; y: Units/int; option(window) list]

   function (string) itemconfigure_get [widget(canvas); "itemconfigure"; TagOrId]

   function () configure_arc [widget(canvas); "itemconfigure"; TagOrId; option(arc) list]

   function () configure_bitmap [widget(canvas); "itemconfigure"; TagOrId; option(bitmap) list]

   function () configure_image [widget(canvas); "itemconfigure"; TagOrId; option(image) list]

   function () configure_line [widget(canvas); "itemconfigure"; TagOrId; option(line) list]

   function () configure_oval [widget(canvas); "itemconfigure"; TagOrId; option(oval) list]

   function () configure_polygon [widget(canvas); "itemconfigure"; TagOrId; option(polygon) list]

   function () configure_rectangle [widget(canvas); "itemconfigure"; TagOrId; option(rectangle) list]

   function () configure_text [widget(canvas); "itemconfigure"; TagOrId; option(canvastext) list]

   function () configure_window [widget(canvas); "itemconfigure"; TagOrId; option(window) list]

   }

%%%%% checkbutton(n)

widget checkbutton {

   % Standard options

   option ActiveBackground

   option ActiveForeground

   option Anchor

   option Background

   option Bitmap

   option BorderWidth

   option Cursor

   option DisabledForeground

   option Font

   option Foreground

   option HighlightBackground

   option HighlightColor

   option HighlightThickness

##ifdef CAMLTK

   option ImageBitmap

   option ImagePhoto

##else

   option Image

##endif

   option Justify

   option PadX

   option PadY

   option Relief

   option TakeFocus

   option Text

   option TextVariable

   option UnderlinedChar

   option WrapLength

   % Widget specific options

   option Command

   option Height

   option IndicatorOn ["-indicatoron"; bool]

   option OffValue ["-offvalue"; string]

   option OnValue  ["-onvalue"; string]

   option SelectColor ["-selectcolor"; Color]

##ifdef CAMLTK

   option SelectImageBitmap (SelectImageBitmap) ["-selectimage"; ImageBitmap]

   option SelectImagePhoto (SelectImagePhoto) ["-selectimage"; ImagePhoto]

##else

   option SelectImage ["-selectimage"; Image]

##endif

   option State

   option Variable ["-variable"; TextVariable]

   option Width

   function () configure [widget(checkbutton); "configure"; option(checkbutton) list]

   function (string) configure_get [widget(checkbutton); "configure"]

   function () deselect [widget(checkbutton);  "deselect"]

   function () flash [widget(checkbutton); "flash"]

   function () invoke [widget(checkbutton); "invoke"]

   function () select [widget(checkbutton); "select"]

   function () toggle [widget(checkbutton); "toggle"]

   }

%%%%% clipboard(n)

subtype icccm(clipboard_append) {

  ICCCMFormat ["-format"; string]

  ICCCMType ["-type"; string]

  }

module Clipboard {

  function () clear ["clipboard"; "clear"; ?displayof:["-displayof"; widget]]

  function () append ["clipboard"; "append"; ?displayof:["-displayof"; widget]; icccm(clipboard_append) list; "--"; data: string]

  }

%%%%% destroy(n)

function () destroy ["destroy"; widget]

%%%%% tk_dialog(n)

module Dialog {

  external create "builtin/dialog"

  }

%%%%% entry(n)

% Defined internally

% subtype Index(entry) {

%    Number End Insert SelFirst SelLast At AnchorPoint

% }

##ifndef CAMLTK

% Only for Labltk. InputState is unified as State in Camltk

type InputState {

   Normal ["normal"]

   Disabled ["disabled"]

}

##endif

widget entry {

   % Standard options

   option Background

   option BorderWidth

   option Cursor

   option ExportSelection

   option Font

   option Foreground

   option HighlightBackground

   option HighlightColor

   option HighlightThickness

   option InsertBackground

   option InsertBorderWidth

   option InsertOffTime

   option InsertOnTime

   option InsertWidth

   option Justify

   option Relief

   option SelectBackground

   option SelectBorderWidth

   option SelectForeground

   option TakeFocus

   option TextVariable

   option XScrollCommand

   % Widget specific options

   option Show ["-show"; char]

##ifdef CAMLTK

   option State

##else

   option EntryState ["-state"; InputState]

##endif

   option TextWidth (Textwidth) ["-width"; int]

   function (int,int,int,int) bbox [widget(entry); "bbox"; Index(entry)]

   function () configure [widget(entry); "configure"; option(entry) list]

   function (string) configure_get [widget(entry); "configure"]

   function () delete_single [widget(entry); "delete"; index: Index(entry)]

   function () delete_range [widget(entry); "delete"; start: Index(entry); stop: Index(entry)]

   function (string) get [widget(entry); "get"]

   function () icursor [widget(entry); "icursor"; index: Index(entry)]

   function (int) index [widget(entry); "index"; index: Index(entry)]

   function () insert [widget(entry); "insert"; index: Index(entry); text: string]

   function () scan_mark [widget(entry); "scan"; "mark"; x: int]

   function () scan_dragto [widget(entry); "scan"; "dragto"; x: int]

   % selection variation

   function () selection_adjust [widget(entry); "selection"; "adjust"; index: Index(entry)]

   function () selection_clear [widget(entry); "selection"; "clear"]

   function () selection_from [widget(entry); "selection"; "from"; index: Index(entry)]

   function (bool) selection_present [widget(entry); "selection"; "present"]

   function () selection_range [widget(entry); "selection"; "range"; start: Index(entry) ; stop: Index(entry)]

   function () selection_to [widget(entry); "selection"; "to"; index: Index(entry)]

   function (float,float) xview_get [widget(entry); "xview"]

   function () xview [widget(entry); "xview"; scroll: ScrollValue]

   function () xview_index [widget(entry); "xview"; index: Index(entry)]

   function (float, float) xview_get [widget(entry); "xview"]

   }

%%%%% focus(n)

%%%%% tk_focusNext(n)

module Focus {

  unsafe function (widget) get ["focus"; ?displayof:["-displayof"; widget]]

  unsafe function (widget) displayof ["focus"; "-displayof"; widget]

  function () set ["focus"; widget]

  function () force ["focus"; "-force"; widget]

  unsafe function (widget) lastfor ["focus"; "-lastfor"; widget]

  unsafe function (widget) next ["tk_focusNext"; widget]

  unsafe function (widget) prev ["tk_focusPrev"; widget]

  function () follows_mouse ["tk_focusFollowsMouse"]

}

type font external % builtin/builtin_font.ml

type weight {

  Weight_Normal(Normal)         ["normal"]

  Weight_Bold(Bold)             ["bold"]

}

type slant {

  Slant_Roman(Roman)            ["roman"]

  Slant_Italic(Italic)          ["italic"]

}

type fontMetrics {

  Ascent ["-ascent"]

  Descent ["-descent"]

  Linespace ["-linespace"]

  Fixed ["-fixed"]

}

subtype options(font) {

  Font_Family   ["-family"; string]

  Font_Size             ["-size"; int]

  Font_Weight   ["-weight"; weight]

  Font_Slant            ["-slant"; slant]

  Font_Underline        ["-underline"; bool]

  Font_Overstrike       ["-overstrike"; bool]

% later, JP only

% Charset                       ["-charset"; string]

%% Beware of the order of Compound ! Put it as the first option

% Compound                      ["-compound"; [font list]]

% Copy                          ["-copy"; string]

}

module Font {

  function (string) actual_family ["font"; "actual"; font;

                                   ?displayof:["-displayof"; widget];

                                   "-family"]

  function (int) actual_size ["font"; "actual"; font;

                                   ?displayof:["-displayof"; widget];

                                   "-size"]

  function (string) actual_weight ["font"; "actual"; font;

                                   ?displayof:["-displayof"; widget];

                                   "-weight"]

  function (string) actual_slant ["font"; "actual"; font;

                                   ?displayof:["-displayof"; widget];

                                   "-slant"]

  function (bool) actual_underline ["font"; "actual"; font;

                                   ?displayof:["-displayof"; widget];

                                   "-underline"]

  function (bool) actual_overstrike ["font"; "actual"; font;

                                   ?displayof:["-displayof"; widget];

                                   "-overstrike"]

  function () configure ["font"; "configure"; font; options(font) list]

  function (font) create ["font"; "create"; ?name:[string]; options(font) list]

##ifdef CAMLTK

  function (font) create_named ["font"; "create"; string; options(font) list]

##endif

  function () delete ["font"; "delete"; font]

  function (string list) families ["font"; "families";

                                ?displayof:["-displayof"; widget]]

##ifdef CAMLTK

  function (string list) families_displayof ["font"; "families";

                                                "-displayof"; widget]

##endif

  function (int) measure ["font"; "measure"; font; string;

                                ?displayof:["-displayof"; widget]]

##ifdef CAMLTK

  function (int) measure_displayof ["font"; "measure"; font;

                                    "-displayof"; widget; string ]

##endif

  function (int) metrics ["font"; "metrics"; font;

                                ?displayof:["-displayof"; widget];

                                fontMetrics ]

##ifdef CAMLTK

  function (int) metrics_displayof ["font"; "metrics"; font;

                                    "-displayof"; widget;

                                    fontMetrics ]

##endif

  function (string list) names ["font"; "names"]

% JP

%  function () failsafe ["font"; "failsafe"; string]

}

%%%%% frame(n)

type Colormap {

  NewColormap (New) ["new"]

  WidgetColormap (Widget) [widget]

  }

% Visual classes are: directcolor, grayscale, greyscale, pseudocolor,

%                     staticcolor, staticgray, staticgrey, truecolor

type Visual {

  ClassVisual (Clas) [[string; int]]

  DefaultVisual ["default"]

  WidgetVisual (Widget) [widget]

  BestDepth (Bestdepth) [["best"; int]]

  Best ["best"]

  }

widget frame {

   % Standard options

   option BorderWidth

   option Cursor

   option HighlightBackground

   option HighlightColor

   option HighlightThickness

   option Relief

   option TakeFocus

   % Widget specific options

   option Background

##ifdef CAMLTK

   option Class  ["-class"; string]

##else

   option Clas  ["-class"; string]

##endif

   option Colormap ["-colormap"; Colormap]

   option Container ["-container"; bool]

   option Height

   option Visual ["-visual"; Visual]

   option Width

   % Class and Colormap and Visual cannot be changed

   function () configure [widget(frame); "configure"; option(frame) list]

   function (string) configure_get [widget(frame); "configure"]

   }

%%%%% grab(n)

type GrabStatus {

   GrabNone ["none"]

   GrabLocal ["local"]

   GrabGlobal ["global"]

}

type GrabGlobal external

module Grab {

   function () set ["grab"; "set"; ?global:[GrabGlobal]; widget]

##ifdef CAMLTK

   function () set_global ["grab"; "set"; "-global"; widget]

##endif

   unsafe function (widget list) current ["grab"; "current"; ?displayof:[widget]]

##ifdef CAMLTK

   % all_current is now current.

   % The old current is now current_of

   unsafe function (widget list) current_of ["grab"; "current"; widget]

##endif

   function () release ["grab"; "release"; widget]

   function (GrabStatus) status ["grab"; "status"; widget]

}

subtype option(rowcolumnconfigure) {

  Minsize ["-minsize"; Units/int]

  Weight  ["-weight"; int]