helm/DEVEL/lablgtk/lablgtk_20000829-0.1.0/gdk.ml

   1 (* $Id$ *)
   2
   3 open Gaux
   4
   5 type colormap
   6 type visual
   7 type region
   8 type gc
   9 type 'a drawable
  10 type window = [`window] drawable
  11 type pixmap = [`pixmap] drawable
  12 type bitmap = [`bitmap] drawable
  13 type font
  14 type image
  15 type atom = int
  16 type keysym = int
  17 type 'a event
  18 type drag_context
  19 type cursor
  20 type xid = int32
  21
  22 exception Error of string
  23 let _ = Callback.register_exception "gdkerror" (Error"")
  24
  25 module Tags = struct
  26   type event_type =
  27     [ `NOTHING|`DELETE|`DESTROY|`EXPOSE|`MOTION_NOTIFY|`BUTTON_PRESS
  28      |`TWO_BUTTON_PRESS|`THREE_BUTTON_PRESS
  29      |`BUTTON_RELEASE|`KEY_PRESS
  30      |`KEY_RELEASE|`ENTER_NOTIFY|`LEAVE_NOTIFY|`FOCUS_CHANGE
  31      |`CONFIGURE|`MAP|`UNMAP|`PROPERTY_NOTIFY|`SELECTION_CLEAR
  32      |`SELECTION_REQUEST|`SELECTION_NOTIFY|`PROXIMITY_IN
  33      |`PROXIMITY_OUT|`DRAG_ENTER|`DRAG_LEAVE|`DRAG_MOTION|`DRAG_STATUS
  34      |`DROP_START|`DROP_FINISHED|`CLIENT_EVENT|`VISIBILITY_NOTIFY
  35      |`NO_EXPOSE ]
  36
  37   type event_mask =
  38     [ `EXPOSURE
  39      |`POINTER_MOTION|`POINTER_MOTION_HINT
  40      |`BUTTON_MOTION|`BUTTON1_MOTION|`BUTTON2_MOTION|`BUTTON3_MOTION
  41      |`BUTTON_PRESS|`BUTTON_RELEASE
  42      |`KEY_PRESS|`KEY_RELEASE
  43      |`ENTER_NOTIFY|`LEAVE_NOTIFY|`FOCUS_CHANGE
  44      |`STRUCTURE|`PROPERTY_CHANGE|`VISIBILITY_NOTIFY
  45      |`PROXIMITY_IN|`PROXIMITY_OUT|`SUBSTRUCTURE
  46      |`ALL_EVENTS ]
  47
  48   type extension_events =
  49     [ `NONE|`ALL|`CURSOR ]
  50
  51   type visibility_state =
  52     [ `UNOBSCURED|`PARTIAL|`FULLY_OBSCURED ]
  53
  54   type input_source =
  55     [ `MOUSE|`PEN|`ERASER|`CURSOR ]
  56
  57   type notify_type =
  58     [ `ANCESTOR|`VIRTUAL|`INFERIOR|`NONLINEAR|`NONLINEAR_VIRTUAL|`UNKNOWN ]
  59
  60   type crossing_mode =
  61     [ `NORMAL|`GRAB|`UNGRAB ]
  62
  63   type modifier =
  64     [ `SHIFT|`LOCK|`CONTROL|`MOD1|`MOD2|`MOD3|`MOD4|`MOD5|`BUTTON1
  65      |`BUTTON2|`BUTTON3|`BUTTON4|`BUTTON5 ]
  66
  67   type drag_action =
  68     [ `DEFAULT|`COPY|`MOVE|`LINK|`PRIVATE|`ASK ]
  69
  70 end
  71 open Tags
  72
  73 module Convert = struct
  74   external test_modifier : modifier -> int -> bool
  75       = "ml_test_GdkModifier_val"
  76   let modifier i =
  77     List.filter [`SHIFT;`LOCK;`CONTROL;`MOD1;`MOD2;`MOD3;`MOD4;`MOD5;
  78                  `BUTTON1;`BUTTON2;`BUTTON3;`BUTTON4;`BUTTON5]
  79       ~f:(fun m -> test_modifier m i)
  80 end
  81
  82 module Screen = struct
  83   external width : unit -> int = "ml_gdk_screen_width"
  84   external height : unit -> int = "ml_gdk_screen_height"
  85 end
  86
  87 module Visual = struct
  88   type visual_type =
  89     [ `STATIC_GRAY|`GRAYSCALE|`STATIC_COLOR
  90      |`PSEUDO_COLOR|`TRUE_COLOR|`DIRECT_COLOR ]
  91
  92   external get_best : ?depth:int -> ?kind:visual_type -> unit -> visual
  93       = "ml_gdk_visual_get_best"
  94   external get_type : visual -> visual_type = "ml_GdkVisual_type"
  95   external depth : visual -> int = "ml_GdkVisual_depth"
  96   external red_mask : visual -> int = "ml_GdkVisual_red_mask"
  97   external red_shift : visual -> int = "ml_GdkVisual_red_shift"
  98   external red_prec : visual -> int = "ml_GdkVisual_red_prec"
  99   external green_mask : visual -> int = "ml_GdkVisual_green_mask"
 100   external green_shift : visual -> int = "ml_GdkVisual_green_shift"
 101   external green_prec : visual -> int = "ml_GdkVisual_green_prec"
 102   external blue_mask : visual -> int = "ml_GdkVisual_blue_mask"
 103   external blue_shift : visual -> int = "ml_GdkVisual_blue_shift"
 104   external blue_prec : visual -> int = "ml_GdkVisual_blue_prec"
 105 end
 106
 107 module Image = struct
 108   type image_type =
 109     [ `NORMAL|`SHARED|`FASTEST ]
 110
 111   external create_bitmap : visual: visual -> data: string ->
 112     width: int -> height: int -> image
 113       = "ml_gdk_image_new_bitmap"
 114   external create : kind: image_type -> visual: visual ->
 115     width: int -> height: int -> image
 116       = "ml_gdk_image_new"
 117   external get :
 118       'a drawable -> x: int -> y: int -> width: int -> height: int -> image
 119       = "ml_gdk_image_get"
 120   external put_pixel : image -> x: int -> y: int -> pixel: int -> unit
 121     = "ml_gdk_image_put_pixel"
 122   external get_pixel : image -> x: int -> y: int -> int
 123     = "ml_gdk_image_get_pixel"
 124   external destroy : image -> unit
 125     = "ml_gdk_image_destroy"
 126 end
 127
 128 module Color = struct
 129   type t
 130
 131   external color_white : colormap -> t = "ml_gdk_color_white"
 132   external color_black : colormap -> t = "ml_gdk_color_black"
 133   external color_parse : string -> t = "ml_gdk_color_parse"
 134   external color_alloc : colormap -> t -> bool = "ml_gdk_color_alloc"
 135   external color_create : red:int -> green:int -> blue:int -> t
 136       = "ml_GdkColor"
 137
 138   external get_system_colormap : unit -> colormap
 139       = "ml_gdk_colormap_get_system"
 140   external colormap_new : visual -> privat:bool -> colormap
 141       = "ml_gdk_colormap_new"
 142   let get_colormap ?(privat=false) vis = colormap_new vis ~privat
 143
 144   type spec = [ `BLACK | `NAME of string | `RGB of int * int * int | `WHITE]
 145   let color_alloc ~colormap color =
 146     if not (color_alloc colormap color) then raise (Error"Color.alloc");
 147     color
 148   let alloc ~colormap color =
 149     match color with
 150       `WHITE -> color_white colormap
 151     | `BLACK -> color_black colormap
 152     | `NAME s -> color_alloc ~colormap (color_parse s)
 153     | `RGB (red,green,blue) ->
 154         color_alloc ~colormap (color_create ~red ~green ~blue)
 155
 156   external red : t -> int = "ml_GdkColor_red"
 157   external blue : t -> int = "ml_GdkColor_blue"
 158   external green : t -> int = "ml_GdkColor_green"
 159   external pixel : t -> int = "ml_GdkColor_pixel"
 160 end
 161
 162 module Rectangle = struct
 163   type t
 164   external create : x:int -> y:int -> width:int -> height:int -> t
 165       = "ml_GdkRectangle"
 166   external x : t -> int = "ml_GdkRectangle_x"
 167   external y : t -> int = "ml_GdkRectangle_y"
 168   external width : t -> int = "ml_GdkRectangle_width"
 169   external height : t -> int = "ml_GdkRectangle_height"
 170 end
 171
 172 module Window = struct
 173   type background_pixmap = [ `NONE | `PARENT_RELATIVE | `PIXMAP of pixmap]
 174   external visual_depth : visual -> int = "ml_gdk_visual_get_depth"
 175   external get_visual : window -> visual = "ml_gdk_window_get_visual"
 176   external get_parent : window -> window = "ml_gdk_window_get_parent"
 177   external get_size : window -> int * int = "ml_gdk_window_get_size"
 178   external get_position : window -> int * int =
 179     "ml_gdk_window_get_position"
 180   external root_parent : unit -> window = "ml_GDK_ROOT_PARENT"
 181   external set_back_pixmap : window -> pixmap -> int -> unit =
 182     "ml_gdk_window_set_back_pixmap"
 183   external clear : window -> unit = "ml_gdk_window_clear"
 184   external get_xwindow : window -> xid = "ml_GDK_WINDOW_XWINDOW"
 185
 186   let set_back_pixmap w pix =
 187     let null_pixmap = (Obj.magic Gpointer.boxed_null : pixmap) in
 188     match pix with
 189       `NONE -> set_back_pixmap w null_pixmap 0
 190     | `PARENT_RELATIVE -> set_back_pixmap w null_pixmap 1
 191     | `PIXMAP(pixmap) -> set_back_pixmap w pixmap 0
 192        (* anything OK, Maybe... *)
 193 end
 194
 195 module PointArray = struct
 196   type t = { len: int}
 197   external create : len:int -> t = "ml_point_array_new"
 198   external set : t -> pos:int -> x:int -> y:int -> unit = "ml_point_array_set"
 199   let set arr ~pos =
 200     if pos < 0 || pos >= arr.len then invalid_arg "PointArray.set";
 201     set arr ~pos
 202 end
 203
 204 module Region = struct
 205   type gdkFillRule = [ `EVEN_ODD_RULE|`WINDING_RULE ]
 206   type gdkOverlapType = [ `IN|`OUT|`PART ]
 207   external create : unit -> region = "ml_gdk_region_new"
 208   external destroy : region -> unit = "ml_gdk_region_destroy"
 209   external polygon : PointArray.t -> gdkFillRule -> region
 210       = "ml_gdk_region_polygon"
 211   let polygon l =
 212     let len = List.length l in
 213     let arr = PointArray.create ~len in
 214     List.fold_left l ~init:0
 215       ~f:(fun pos (x,y) -> PointArray.set arr ~pos ~x ~y; pos+1);
 216     polygon arr
 217   external intersect : region -> region -> region
 218       = "ml_gdk_regions_intersect"
 219   external union : region -> region -> region
 220       = "ml_gdk_regions_union"
 221   external subtract : region -> region -> region
 222       = "ml_gdk_regions_subtract"
 223   external xor : region -> region -> region
 224       = "ml_gdk_regions_xor"
 225   external union_with_rect : region -> Rectangle.t -> region
 226       = "ml_gdk_region_union_with_rect"
 227   external offset : region -> x:int -> y:int -> unit = "ml_gdk_region_offset"
 228   external shrink : region -> x:int -> y:int -> unit = "ml_gdk_region_shrink"
 229   external empty : region -> bool = "ml_gdk_region_empty"
 230   external equal : region -> region -> bool = "ml_gdk_region_equal"
 231   external point_in : region -> x:int -> y:int -> bool
 232       = "ml_gdk_region_point_in"
 233   external rect_in : region -> Rectangle.t -> gdkOverlapType
 234       = "ml_gdk_region_rect_in"
 235   external get_clipbox : region -> Rectangle.t -> unit
 236       = "ml_gdk_region_get_clipbox"
 237 end
 238
 239
 240 module GC = struct
 241   type gdkFunction = [ `COPY|`INVERT|`XOR ]
 242   type gdkFill = [ `SOLID|`TILED|`STIPPLED|`OPAQUE_STIPPLED ]
 243   type gdkSubwindowMode = [ `CLIP_BY_CHILDREN|`INCLUDE_INFERIORS ]
 244   type gdkLineStyle = [ `SOLID|`ON_OFF_DASH|`DOUBLE_DASH ]
 245   type gdkCapStyle = [ `NOT_LAST|`BUTT|`ROUND|`PROJECTING ]
 246   type gdkJoinStyle = [ `MITER|`ROUND|`BEVEL ]
 247   external create : 'a drawable -> gc = "ml_gdk_gc_new"
 248   external set_foreground : gc -> Color.t -> unit = "ml_gdk_gc_set_foreground"
 249   external set_background : gc -> Color.t -> unit = "ml_gdk_gc_set_background"
 250   external set_font : gc -> font -> unit = "ml_gdk_gc_set_font"
 251   external set_function : gc -> gdkFunction -> unit = "ml_gdk_gc_set_function"
 252   external set_fill : gc -> gdkFill -> unit = "ml_gdk_gc_set_fill"
 253   external set_tile : gc -> pixmap -> unit = "ml_gdk_gc_set_tile"
 254   external set_stipple : gc -> pixmap -> unit = "ml_gdk_gc_set_stipple"
 255   external set_ts_origin : gc -> x:int -> y:int -> unit
 256       = "ml_gdk_gc_set_ts_origin"
 257   external set_clip_origin : gc -> x:int -> y:int -> unit
 258       = "ml_gdk_gc_set_clip_origin"
 259   external set_clip_mask : gc -> bitmap -> unit = "ml_gdk_gc_set_clip_mask"
 260   external set_clip_rectangle : gc -> Rectangle.t -> unit
 261       = "ml_gdk_gc_set_clip_rectangle"
 262   external set_clip_region : gc -> region -> unit = "ml_gdk_gc_set_clip_region"
 263   external set_subwindow : gc -> gdkSubwindowMode -> unit
 264       = "ml_gdk_gc_set_subwindow"
 265   external set_exposures : gc -> bool -> unit = "ml_gdk_gc_set_exposures"
 266   external set_line_attributes :
 267       gc -> width:int -> style:gdkLineStyle -> cap:gdkCapStyle ->
 268       join:gdkJoinStyle -> unit
 269       = "ml_gdk_gc_set_line_attributes"
 270   external copy : dst:gc -> gc -> unit = "ml_gdk_gc_copy"
 271   type values = {
 272       foreground : Color.t;
 273       background : Color.t;
 274       font : font option;
 275       fonction : gdkFunction;
 276       fill : gdkFill;
 277       tile : pixmap option;
 278       stipple : pixmap option;
 279       clip_mask : bitmap option;
 280       subwindow_mode : gdkSubwindowMode;
 281       ts_x_origin : int;
 282       ts_y_origin : int;
 283       clip_x_origin : int;
 284       clip_y_origin : int;
 285       graphics_exposures : bool;
 286       line_width : int;
 287       line_style : gdkLineStyle;
 288       cap_style : gdkCapStyle;
 289       join_style : gdkJoinStyle;
 290     }
 291   external get_values : gc -> values = "ml_gdk_gc_get_values"
 292 end
 293
 294 module Pixmap = struct
 295   external create : window -> width:int -> height:int -> depth:int -> pixmap
 296       = "ml_gdk_pixmap_new"
 297   external create_from_data :
 298       window -> string -> width:int -> height:int -> depth:int ->
 299       fg:Color.t -> bg:Color.t -> pixmap
 300       = "ml_gdk_pixmap_create_from_data_bc" "ml_gk_pixmap_create_from_data"
 301   external create_from_xpm :
 302       window -> ?colormap:colormap -> ?transparent:Color.t ->
 303       file:string -> pixmap * bitmap
 304       = "ml_gdk_pixmap_colormap_create_from_xpm"
 305   external create_from_xpm_d :
 306       window -> ?colormap:colormap -> ?transparent:Color.t ->
 307       data:string array -> pixmap * bitmap
 308       = "ml_gdk_pixmap_colormap_create_from_xpm_d"
 309 end
 310
 311 module Bitmap = struct
 312   let create : window -> width:int -> height:int -> bitmap =
 313     Obj.magic (Pixmap.create ~depth:1)
 314   external create_from_data :
 315       window -> string -> width:int -> height:int -> bitmap
 316       = "ml_gdk_bitmap_create_from_data"
 317 end
 318
 319 module Font = struct
 320   external load : string -> font = "ml_gdk_font_load"
 321   external load_fontset : string -> font = "ml_gdk_fontset_load"
 322   external string_width : font -> string -> int = "ml_gdk_string_width"
 323   external char_width : font -> char -> int = "ml_gdk_char_width"
 324   external string_height : font -> string -> int = "ml_gdk_string_height"
 325   external char_height : font -> char -> int = "ml_gdk_char_height"
 326   external string_measure : font -> string -> int = "ml_gdk_string_measure"
 327   external char_measure : font -> char -> int = "ml_gdk_char_measure"
 328   external get_type : font -> [`FONT | `FONTSET] = "ml_GdkFont_type"
 329   external ascent : font -> int = "ml_GdkFont_ascent"
 330   external descent : font -> int = "ml_GdkFont_descent"
 331 end
 332
 333 module Draw = struct
 334   external point : 'a drawable -> gc -> x:int -> y:int -> unit
 335       = "ml_gdk_draw_point"
 336   external line : 'a drawable -> gc -> x:int -> y:int -> x:int -> y:int -> unit
 337       = "ml_gdk_draw_line_bc" "ml_gdk_draw_line"
 338   external rectangle :
 339       'a drawable -> gc ->
 340       filled:bool -> x:int -> y:int -> width:int -> height:int -> unit
 341       = "ml_gdk_draw_rectangle_bc" "ml_gdk_draw_rectangle"
 342   let rectangle w gc ~x ~y ~width ~height ?(filled=false) () =
 343     rectangle w gc ~x ~y ~width ~height ~filled
 344   external arc :
 345       'a drawable -> gc -> filled:bool -> x:int -> y:int ->
 346       width:int -> height:int -> start:int -> angle:int -> unit
 347       = "ml_gdk_draw_arc_bc" "ml_gdk_draw_arc"
 348   let arc w gc ~x ~y ~width ~height ?(filled=false) ?(start=0.)
 349       ?(angle=360.) () =
 350     arc w gc ~x ~y ~width ~height ~filled
 351       ~start:(truncate(start *. 64.))
 352       ~angle:(truncate(angle *. 64.))
 353   external polygon : 'a drawable -> gc -> filled:bool -> PointArray.t -> unit
 354       = "ml_gdk_draw_polygon"
 355   let polygon w gc ?(filled=false) l =
 356     let len = List.length l in
 357     let arr = PointArray.create ~len in
 358     List.fold_left l ~init:0
 359       ~f:(fun pos (x,y) -> PointArray.set arr ~pos ~x ~y; pos+1);
 360     polygon w gc ~filled arr
 361   external string : 'a drawable -> font: font -> gc -> x: int -> y: int ->
 362     string: string -> unit
 363       = "ml_gdk_draw_string_bc" "ml_gdk_draw_string"
 364   external image : 'a drawable -> gc -> image: image ->
 365     xsrc: int -> ysrc: int -> xdest: int -> ydest: int ->
 366     width: int -> height: int -> unit
 367       = "ml_gdk_draw_image_bc" "ml_gdk_draw_image"
 368 end
 369
 370 module Rgb = struct
 371   external init : unit -> unit = "ml_gdk_rgb_init"
 372   external get_visual : unit -> visual = "ml_gdk_rgb_get_visual"
 373   external get_cmap : unit -> colormap = "ml_gdk_rgb_get_cmap"
 374 end
 375
 376 module DnD = struct
 377   external drag_status : drag_context -> drag_action list -> time:int -> unit
 378       = "ml_gdk_drag_status"
 379   external drag_context_suggested_action : drag_context -> drag_action
 380       = "ml_GdkDragContext_suggested_action"
 381   external drag_context_targets : drag_context -> atom list
 382       = "ml_GdkDragContext_targets"
 383 end
 384
 385 module Truecolor = struct
 386   (* Truecolor quick color query *)
 387
 388   type visual_shift_prec = {
 389       red_shift : int;
 390       red_prec : int;
 391       green_shift : int;
 392       green_prec : int;
 393       blue_shift : int;
 394       blue_prec : int
 395     }
 396
 397   let shift_prec visual = {
 398     red_shift = Visual.red_shift visual;
 399     red_prec = Visual.red_prec visual;
 400     green_shift = Visual.green_shift visual;
 401     green_prec = Visual.green_prec visual;
 402     blue_shift = Visual.blue_shift visual;
 403     blue_prec = Visual.blue_prec visual;
 404   }
 405
 406   let color_creator visual =
 407     match Visual.get_type visual with
 408       `TRUE_COLOR | `DIRECT_COLOR ->
 409         let shift_prec = shift_prec visual in
 410         Format.eprintf "red : %d %d, "
 411           shift_prec.red_shift shift_prec.red_prec;
 412         Format.eprintf "green : %d %d, "
 413           shift_prec.green_shift shift_prec.green_prec;
 414         Format.eprintf "blue : %d %d"
 415           shift_prec.blue_shift shift_prec.blue_prec;
 416         Format.pp_print_newline Format.err_formatter ();
 417         let red_lsr = 16 - shift_prec.red_prec
 418         and green_lsr = 16 - shift_prec.green_prec
 419         and blue_lsr = 16 - shift_prec.blue_prec in
 420         fun ~red: red ~green: green ~blue: blue ->
 421           (((red lsr red_lsr) lsl shift_prec.red_shift) lor
 422            ((green lsr green_lsr) lsl shift_prec.green_shift) lor
 423            ((blue lsr blue_lsr) lsl shift_prec.blue_shift))
 424     | _ -> raise (Invalid_argument "Gdk.Truecolor.color_creator")
 425
 426   let color_parser visual =
 427     match Visual.get_type visual with
 428       `TRUE_COLOR | `DIRECT_COLOR ->
 429         let shift_prec = shift_prec visual in
 430         let red_lsr = 16 - shift_prec.red_prec
 431         and green_lsr = 16 - shift_prec.green_prec
 432         and blue_lsr = 16 - shift_prec.blue_prec in
 433         let mask = 1 lsl 16 - 1 in
 434         fun pixel ->
 435           ((pixel lsr shift_prec.red_shift) lsl red_lsr) land mask,
 436           ((pixel lsr shift_prec.green_shift) lsl green_lsr) land mask,
 437           ((pixel lsr shift_prec.blue_shift) lsl blue_lsr) land mask
 438     | _ -> raise (Invalid_argument "Gdk.Truecolor.color_parser")
 439 end
 440
 441 module X = struct
 442   (* X related functions *)
 443   external flush : unit -> unit
 444       = "ml_gdk_flush"
 445   external beep : unit -> unit
 446       = "ml_gdk_beep"
 447 end
 448
 449 module Cursor = struct
 450   type cursor_type = [
 451     | `X_CURSOR
 452     | `ARROW
 453     | `BASED_ARROW_DOWN
 454     | `BASED_ARROW_UP
 455     | `BOAT
 456     | `BOGOSITY
 457     | `BOTTOM_LEFT_CORNER
 458     | `BOTTOM_RIGHT_CORNER
 459     | `BOTTOM_SIDE
 460     | `BOTTOM_TEE
 461     | `BOX_SPIRAL
 462     | `CENTER_PTR
 463     | `CIRCLE
 464     | `CLOCK
 465     | `COFFEE_MUG
 466     | `CROSS
 467     | `CROSS_REVERSE
 468     | `CROSSHAIR
 469     | `DIAMOND_CROSS
 470     | `DOT
 471     | `DOTBOX
 472     | `DOUBLE_ARROW
 473     | `DRAFT_LARGE
 474     | `DRAFT_SMALL
 475     | `DRAPED_BOX
 476     | `EXCHANGE
 477     | `FLEUR
 478     | `GOBBLER
 479     | `GUMBY
 480     | `HAND1
 481     | `HAND2
 482     | `HEART
 483     | `ICON
 484     | `IRON_CROSS
 485     | `LEFT_PTR
 486     | `LEFT_SIDE
 487     | `LEFT_TEE
 488     | `LEFTBUTTON
 489     | `LL_ANGLE
 490     | `LR_ANGLE
 491     | `MAN
 492     | `MIDDLEBUTTON
 493     | `MOUSE
 494     | `PENCIL
 495     | `PIRATE
 496     | `PLUS
 497     | `QUESTION_ARROW
 498     | `RIGHT_PTR
 499     | `RIGHT_SIDE
 500     | `RIGHT_TEE
 501     | `RIGHTBUTTON
 502     | `RTL_LOGO
 503     | `SAILBOAT
 504     | `SB_DOWN_ARROW
 505     | `SB_H_DOUBLE_ARROW
 506     | `SB_LEFT_ARROW
 507     | `SB_RIGHT_ARROW
 508     | `SB_UP_ARROW
 509     | `SB_V_DOUBLE_ARROW
 510     | `SHUTTLE
 511     | `SIZING
 512     | `SPIDER
 513     | `SPRAYCAN
 514     | `STAR
 515     | `TARGET
 516     | `TCROSS
 517     | `TOP_LEFT_ARROW
 518     | `TOP_LEFT_CORNER
 519     | `TOP_RIGHT_CORNER
 520     | `TOP_SIDE
 521     | `TOP_TEE
 522     | `TREK
 523     | `UL_ANGLE
 524     | `UMBRELLA
 525     | `UR_ANGLE
 526     | `WATCH
 527     | `XTERM
 528   ]
 529   external create : cursor_type -> cursor = "ml_gdk_cursor_new"
 530   external create_from_pixmap :
 531     pixmap -> mask:bitmap ->
 532     fg:Color.t -> bg:Color.t -> x:int -> y:int -> cursor
 533     = "ml_gdk_cursor_new_from_pixmap_bc" "ml_gdk_cursor_new_from_pixmap"
 534   external destroy : cursor -> unit = "ml_gdk_cursor_destroy"
 535 end