diff options
35 files changed, 552 insertions, 695 deletions
diff --git a/otherlibs/labltk/Widgets.src b/otherlibs/labltk/Widgets.src index aa0323737..da3c2054b 100644 --- a/otherlibs/labltk/Widgets.src +++ b/otherlibs/labltk/Widgets.src @@ -57,12 +57,12 @@ type Units external # builtin_GetPixel.ml ##### The subtype is never used subtype option(standard) { ActiveBackground ["-activebackground"; Color] - ActiveBorderWidth ["-activeborderwidth"; Units] + ActiveBorderWidth ["-activeborderwidth"; int] ActiveForeground ["-activeforeground"; Color] Anchor ["-anchor"; Anchor] Background ["-background"; Color] Bitmap ["-bitmap"; Bitmap] - BorderWidth ["-borderwidth"; Units] + BorderWidth ["-borderwidth"; int] Cursor ["-cursor"; Cursor] DisabledForeground ["-disabledforeground"; Color] ExportSelection ["-exportselection"; bool] @@ -71,26 +71,26 @@ subtype option(standard) { Geometry ["-geometry"; string] # Too variable to encode HighlightBackground ["-highlightbackground"; Color] HighlightColor ["-highlightcolor"; Color] - HighlightThickness ["-highlightthickness"; Units] + HighlightThickness ["-highlightthickness"; int] Image ["-image"; Image] # it is old # images are split, to do additionnal static typing # ImageBitmap (ImageBitmap) ["-image"; ImageBitmap] # ImagePhoto (ImagePhoto) ["-image"; ImagePhoto] InsertBackground ["-insertbackground"; Color] - InsertBorderWidth ["-insertborderwidth"; Units] + InsertBorderWidth ["-insertborderwidth"; int] InsertOffTime ["-insertofftime"; int] # Positive only InsertOnTime ["-insertontime"; int] # Idem - InsertWidth ["-insertwidth"; Units] + InsertWidth ["-insertwidth"; int] Jump ["-jump"; bool] Justify ["-justify"; Justification] Orient ["-orient"; Orientation] - PadX ["-padx"; Units] - PadY ["-pady"; Units] + PadX ["-padx"; int] + PadY ["-pady"; int] Relief ["-relief"; Relief] RepeatDelay ["-repeatdelay"; int] RepeatInterval ["-repeatinterval"; int] SelectBackground ["-selectbackground"; Color] - SelectBorderWidth ["-selectborderwidth"; Units] + SelectBorderWidth ["-selectborderwidth"; int] SelectForeground ["-selectforeground"; Color] SetGrid ["-setgrid"; bool] # incomplete description of TakeFocus @@ -99,7 +99,7 @@ subtype option(standard) { TextVariable ["-textvariable"; TextVariable] TroughColor ["-troughcolor"; Color] UnderlinedChar ["-underline"; int] - WrapLength ["-wraplength"; Units] + WrapLength ["-wraplength"; int] # Major incompatibility with Tk3.6 where it was function(int,int,int,int) XScrollCommand ["-xscrollcommand"; function(first:float, last:float)] YScrollCommand ["-yscrollcommand"; function(first:float, last:float)] @@ -196,9 +196,9 @@ widget button { option WrapLength # Widget specific options option Command ["-command"; function ()] - option Height ["-height"; Units] + option Height ["-height"; int] option State ["-state"; State] - option Width ["-width"; Units] + option Width ["-width"; int] function () configure [widget(button); "configure"; option(button) list] function (string) configure_get [widget(button); "configure"] @@ -223,10 +223,10 @@ type SearchSpec { Above ["above"; TagOrId] All ["all"] Below ["below"; TagOrId] - Closest ["closest"; Units; Units] - ClosestHalo (Closesthalo) ["closest"; Units; Units; Units] - ClosestHaloStart (Closesthalostart) ["closest"; Units; Units; Units; TagOrId] - Enclosed ["enclosed"; Units;Units;Units;Units] + Closest ["closest"; int; int] + ClosestHalo (Closesthalo) ["closest"; int; int; int] + ClosestHaloStart (Closesthalostart) ["closest"; int; int; int; TagOrId] + Enclosed ["enclosed"; int;int;int;int] Overlapping ["overlapping"; int;int;int;int] Withtag ["withtag"; TagOrId] } @@ -245,14 +245,14 @@ subtype option(postscript) { # Fontmap ["-fontmap"; TextVariable] Height PageAnchor ["-pageanchor"; Anchor] - PageHeight ["-pageheight"; Units] - PageWidth ["-pagewidth"; Units] - PageX ["-pagex"; Units] - PageY ["-pagey"; Units] + PageHeight ["-pageheight"; int] + PageWidth ["-pagewidth"; int] + PageX ["-pagex"; int] + PageY ["-pagey"; int] Rotate ["-rotate"; bool] Width - X ["-x"; Units] - Y ["-y"; Units] + X ["-x"; int] + Y ["-y"; int] } @@ -316,7 +316,7 @@ type JoinStyle { subtype option(line) { ArrowStyle ["-arrow"; ArrowStyle] - ArrowShape ["-arrowshape"; [Units; Units; Units]] + ArrowShape ["-arrowshape"; [int; int; int]] CapStyle ["-capstyle"; CapStyle] FillColor JoinStyle ["-joinstyle"; JoinStyle] @@ -392,11 +392,11 @@ widget canvas { # Widget specific options option CloseEnough ["-closeenough"; float] option Confine ["-confine"; bool] - option Height ["-height"; Units] - option ScrollRegion ["-scrollregion"; [Units;Units;Units;Units]] - option Width ["-width"; Units] - option XScrollIncrement ["-xscrollincrement"; Units] - option YScrollIncrement ["-yscrollincrement"; Units] + option Height ["-height"; int] + option ScrollRegion ["-scrollregion"; [int;int;int;int]] + option Width ["-width"; int] + option XScrollIncrement ["-xscrollincrement"; int] + option YScrollIncrement ["-yscrollincrement"; int] function () addtag [widget(canvas); "addtag"; tag: TagOrId; specs: SearchSpec list] # Tag only @@ -404,17 +404,17 @@ widget canvas { # will raise protocol__TkError if no items match TagOrId function (int,int,int,int) bbox [widget(canvas); "bbox"; tags: TagOrId list] external bind "builtin/canvas_bind" - function (float) canvasx [widget(canvas); "canvasx"; x:Units; ?spacing:[Units]] -# function (float) canvasx [widget(canvas); "canvasx"; x:Units] -# function (float) canvasx_grid [widget(canvas); "canvasx"; x:Units; spacing:Units] - function (float) canvasy [widget(canvas); "canvasy"; y:Units; ?spacing:[Units]] -# function (float) canvasy [widget(canvas); "canvasy"; y:Units] -# function (float) canvasy_grid [widget(canvas); "canvasy"; y:Units; spacing:Units] + function (float) canvasx [widget(canvas); "canvasx"; x:int; ?spacing:[int]] +# function (float) canvasx [widget(canvas); "canvasx"; x:int] +# function (float) canvasx_grid [widget(canvas); "canvasx"; x:int; spacing:int] + function (float) canvasy [widget(canvas); "canvasy"; y:int; ?spacing:[int]] +# function (float) canvasy [widget(canvas); "canvasy"; y:int] +# function (float) canvasy_grid [widget(canvas); "canvasy"; y:int; spacing:int] 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"; tag: TagOrId] - function () coords_set [widget(canvas); "coords"; tag: TagOrId; coords: Units list] + function () coords_set [widget(canvas); "coords"; tag: TagOrId; coords: int list] # create variations (see below) function () dchars [widget(canvas); "dchars"; tag: TagOrId; first: Index(canvas); last: Index(canvas)] function () delete [widget(canvas); "delete"; tags: TagOrId list] @@ -432,13 +432,13 @@ widget canvas { # configure variations, see below # function () lower_below [widget(canvas); "lower"; tag: TagOrId; below: TagOrId] # function () lower_bot [widget(canvas); "lower"; tag: TagOrId] - function () move [widget(canvas); "move"; tag: TagOrId; x: Units; y: Units] + function () move [widget(canvas); "move"; tag: TagOrId; x: int; y: int] unsafe function (string) postscript [widget(canvas); "postscript"; option(postscript) list] # We use raise... with Module name function () raise [widget(canvas); "raise"; tag: TagOrId; ?above:[TagOrId]] # function () raise_above [widget(canvas); "raise"; tag: TagOrId; above: TagOrId] # function () raise_top [widget(canvas); "raise"; tag: TagOrId] - function () scale [widget(canvas); "scale"; tag: TagOrId; xorigin: Units; yorigin: Units; xscale: float; yscale: float] + function () scale [widget(canvas); "scale"; tag: TagOrId; xorigin: int; yorigin: 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] @@ -456,15 +456,15 @@ widget canvas { function () yview [widget(canvas); "yview"; scroll: ScrollValue] # create and configure variations - function (TagOrId) create_arc [widget(canvas); "create"; "arc"; x1: Units; y1: Units; x2: Units; y2: Units; option(arc) list] - function (TagOrId) create_bitmap [widget(canvas); "create"; "bitmap"; x: Units; y: Units; option(bitmap) list] - function (TagOrId) create_image [widget(canvas); "create"; "image"; x: Units; y: Units; option(image) list] - function (TagOrId) create_line [widget(canvas); "create"; "line"; xys: Units list; option(line) list] - function (TagOrId) create_oval [widget(canvas); "create"; "oval"; x1: Units; y1: Units; x2: Units; y2: Units; option(oval) list] - function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; xys: Units list; option(polygon) list] - function (TagOrId) create_rectangle [widget(canvas); "create"; "rectangle"; x1: Units; y1: Units; x2: Units; y2: Units; option(rectangle) list] - function (TagOrId) create_text [widget(canvas); "create"; "text"; x: Units; y: Units; option(canvastext) list] - function (TagOrId) create_window [widget(canvas); "create"; "window"; x: Units; y: Units; option(window) list] + function (TagOrId) create_arc [widget(canvas); "create"; "arc"; x1: int; y1: int; x2: int; y2: int; option(arc) list] + function (TagOrId) create_bitmap [widget(canvas); "create"; "bitmap"; x: int; y: int; option(bitmap) list] + function (TagOrId) create_image [widget(canvas); "create"; "image"; x: int; y: int; option(image) list] + function (TagOrId) create_line [widget(canvas); "create"; "line"; xys: int list; option(line) list] + function (TagOrId) create_oval [widget(canvas); "create"; "oval"; x1: int; y1: int; x2: int; y2: int; option(oval) list] + function (TagOrId) create_polygon [widget(canvas); "create"; "polygon"; xys: int list; option(polygon) list] + function (TagOrId) create_rectangle [widget(canvas); "create"; "rectangle"; x1: int; y1: int; x2: int; y2: int; option(rectangle) list] + function (TagOrId) create_text [widget(canvas); "create"; "text"; x: int; y: int; option(canvastext) list] + function (TagOrId) create_window [widget(canvas); "create"; "window"; x: int; y: int; option(window) list] function (string) itemconfigure_get [widget(canvas); "itemconfigure"; tag: TagOrId] @@ -689,7 +689,7 @@ module Grab { } subtype option(rowcolumnconfigure) { - Minsize ["-minsize"; Units] + Minsize ["-minsize"; int] Weight ["-weight"; float] } @@ -697,8 +697,8 @@ subtype option(grid) { Column ["-column"; int] ColumnSpan ["-columnspan"; int] In ["-in"; widget] - IPadX ["-ipadx"; Units] - IPadY ["-ipady"; Units] + IPadX ["-ipadx"; int] + IPadY ["-ipady"; int] PadX PadY Row ["-row"; int] @@ -1112,8 +1112,8 @@ subtype option(pack) { Expand ["-expand"; bool] Fill ["-fill"; FillMode] In ["-in"; widget] - IPadX ["-ipadx"; Units] - IPadY ["-ipady"; Units] + IPadX ["-ipadx"; int] + IPadY ["-ipady"; int] PadX PadY Side ["-side"; Side] @@ -1299,7 +1299,7 @@ function () raise_window ["raise"; widget; ?above:[widget]] ##### scale(n) ## shared with scrollbars -subtype WidgetElement(scale) { +type ScaleElement { Slider ["slider"] Trough1 ["trough1"] Trough2 ["trough2"] @@ -1330,10 +1330,10 @@ widget scale { option Digits ["-digits"; int] option From ["-from"; float] option Label ["-label"; string] - option Length ["-length"; Units] + option Length ["-length"; int] option Resolution ["-resolution"; float] option ShowValue ["-showvalue"; bool] - option SliderLength ["-sliderlength"; Units] + option SliderLength ["-sliderlength"; int] option State option TickInterval ["-tickinterval"; float] option To ["-to"; float] @@ -1344,19 +1344,19 @@ widget scale { function (string) configure_get [widget(scale); "configure"] function (float) get [widget(scale); "get"] function (float) get_xy [widget(scale); "get"; x: int; y: int] - function (WidgetElement(scale)) identify [widget(scale); x: int; y: int] + function (ScaleElement) identify [widget(scale); x: int; y: int] function () set [widget(scale); "set"; to: float] } ##### scrollbar(n) -subtype WidgetElement(scrollbar) { +type ScrollbarElement { Arrow1 ["arrow1"] - Trough1 - Trough2 - Slider + Trough1 ["through1"] + Trough2 ["through2"] + Slider ["slider"] Arrow2 ["arrow2"] - Beyond + Beyond [""] } widget scrollbar { @@ -1378,18 +1378,18 @@ widget scrollbar { # Widget specific options option ActiveRelief ["-activerelief"; Relief] option ScrollCommand ["-command"; function(scroll: ScrollValue)] - option ElementBorderWidth ["-elementborderwidth"; Units] + option ElementBorderWidth ["-elementborderwidth"; int] option Width - function () activate [widget(scrollbar); "activate"; element: WidgetElement(scrollbar)] - function (WidgetElement(scrollbar)) activate_get [widget(scrollbar); "activate"] + function () activate [widget(scrollbar); "activate"; element: ScrollbarElement] + function (ScrollbarElement) activate_get [widget(scrollbar); "activate"] function () configure [widget(scrollbar); "configure"; option(scrollbar) list] function (string) configure_get [widget(scrollbar); "configure"] function (float) delta [widget(scrollbar); "delta"; x: int; y: int] function (float) fraction [widget(scrollbar); "fraction"; x: int; y: int] function (float, float) get [widget(scrollbar); "get"] function (int, int, int, int) old_get [widget(scrollbar); "get"] - function (WidgetElement(scrollbar)) identify [widget(scrollbar); "identify"; x: int; y: int] + function (ScrollbarElement) identify [widget(scrollbar); "identify"; x: int; y: int] function () set [widget(scrollbar); "set"; first: float; last: float] function () old_set [widget(scrollbar); "set"; total:int; window:int; first:int; last:int] } @@ -1439,10 +1439,10 @@ type TextMark external type TabType { - TabLeft [Units; "left"] - TabRight [Units; "right"] - TabCenter [Units; "center"] - TabNumeric [Units; "numeric"] + TabLeft [int; "left"] + TabRight [int; "right"] + TabCenter [int; "center"] + TabNumeric [int; "numeric"] } type WrapMode { @@ -1527,9 +1527,9 @@ widget text { # Widget specific options option TextHeight - option Spacing1 ["-spacing1"; Units] - option Spacing2 ["-spacing2"; Units] - option Spacing3 ["-spacing3"; Units] + option Spacing1 ["-spacing1"; int] + option Spacing2 ["-spacing2"; int] + option Spacing3 ["-spacing3"; int] option State option Tabs ["-tabs"; [TabType list]] option TextWidth @@ -1605,12 +1605,12 @@ subtype option(texttag) { Font Foreground Justify - LMargin1 ["-lmargin1"; Units] - LMargin2 ["-lmargin2"; Units] - Offset ["-offset"; Units] + LMargin1 ["-lmargin1"; int] + LMargin2 ["-lmargin2"; int] + Offset ["-offset"; int] OverStrike ["-overstrike"; bool] Relief - RMargin ["-rmargin"; Units] + RMargin ["-rmargin"; int] Spacing1 Spacing2 Spacing3 diff --git a/otherlibs/labltk/browser/editor.ml b/otherlibs/labltk/browser/editor.ml index ed07b7ec4..a03ecdfdb 100644 --- a/otherlibs/labltk/browser/editor.ml +++ b/otherlibs/labltk/browser/editor.ml @@ -27,7 +27,7 @@ let compiler_preferences () = "Type on load", type_on_load]) in let buttons = Frame.create tl in - let ok = Button.create buttons text:"Ok" padx:(`Pix 20) command: + let ok = Button.create buttons text:"Ok" padx:20 command: begin fun () -> List.iter fun:(fun f -> f ()) setflags; destroy tl @@ -102,12 +102,13 @@ let select_shell txt = in Listbox.insert box index:`End texts:(List.map fun:fst shells); Listbox.configure box height:(List.length shells); - bind box events:[[],`KeyPressDetail"Return"] - action:(`Setbreakable([], fun _ -> Button.invoke ok; break ())); - bind box events:[[`Double],`ButtonPressDetail 1] - action:(`Setbreakable([`MouseX;`MouseY], fun ev -> + bind box events:[`KeyPressDetail"Return"] breakable:true + action:(fun _ -> Button.invoke ok; break ()); + bind box events:[`Modified([`Double],`ButtonPressDetail 1)] breakable:true + fields:[`MouseX;`MouseY] + action:(fun ev -> Listbox.activate box index:(`Atxy (ev.ev_MouseX, ev.ev_MouseY)); - Button.invoke ok; break ())); + Button.invoke ok; break ()); pack [label] side:`Top anchor:`W; pack [box] side:`Top fill:`Both; pack [frame] side:`Bottom fill:`X expand:true; @@ -308,45 +309,44 @@ class editor :top :menus = object (self) structure = []; signature = []; psignature = [] } in let control c = Char.chr (Char.code c - 96) in - bind tw events:[[`Alt], `KeyPress] action:(`Set ([], fun _ -> ())); - bind tw events:[[], `KeyPress] - action:(`Set ([`Char], fun ev -> + bind tw events:[`Modified([`Alt], `KeyPress)] action:ignore; + bind tw events:[`KeyPress] fields:[`Char] + action:(fun ev -> if ev.ev_Char <> "" & (ev.ev_Char.[0] >= ' ' or List.mem key:ev.ev_Char.[0] (List.map fun:control ['d'; 'h'; 'i'; 'k'; 'o'; 't'; 'w'; 'y'])) - then Textvariable.set txt.modified to:"modified")); - bind tw events:[[],`KeyPressDetail"Tab"] - action:(`Setbreakable ([], fun _ -> + then Textvariable.set txt.modified to:"modified"); + bind tw events:[`KeyPressDetail"Tab"] breakable:true + action:(fun _ -> indent_line tw; Textvariable.set txt.modified to:"modified"; - break ())); - bind tw events:[[`Control],`KeyPressDetail"k"] - action:(`Set ([], fun _ -> + break ()); + bind tw events:[`Modified([`Control],`KeyPressDetail"k")] + action:(fun _ -> let text = Text.get tw start:(`Mark"insert",[]) end:(`Mark"insert",[`Lineend]) in Str.string_match pat:(Str.regexp "[ \t]*") text pos:0; if Str.match_end () <> String.length text then begin Clipboard.clear (); Clipboard.append data:text () - end)); - bind tw events:[[], `KeyRelease] - action:(`Set ([`Char], fun ev -> + end); + bind tw events:[`KeyRelease] fields:[`Char] + action:(fun ev -> if ev.ev_Char <> "" then Lexical.tag tw start:(`Mark"insert", [`Linestart]) - end:(`Mark"insert", [`Lineend]))); - bind tw events:[[], `Motion] action:(`Set ([], fun _ -> Focus.set tw)); - bind tw events:[[], `ButtonPressDetail 2] - action:(`Set ([], fun _ -> + end:(`Mark"insert", [`Lineend])); + bind tw events:[`Motion] action:(fun _ -> Focus.set tw); + bind tw events:[`ButtonPressDetail 2] + action:(fun _ -> Textvariable.set txt.modified to:"modified"; Lexical.tag txt.tw start:(`Mark"insert", [`Linestart]) - end:(`Mark"insert", [`Lineend]))); - bind tw events:[[`Double], `ButtonPressDetail 1] - action:(`Set ([`MouseX;`MouseY], fun ev -> - search_pos_window txt x:ev.ev_MouseX y:ev.ev_MouseY)); - bind tw events:[[], `ButtonPressDetail 3] - action:(`Set ([`MouseX;`MouseY], fun ev -> - search_pos_menu txt x:ev.ev_MouseX y:ev.ev_MouseY)); + end:(`Mark"insert", [`Lineend])); + bind tw events:[`Modified([`Double], `ButtonPressDetail 1)] + fields:[`MouseX;`MouseY] + action:(fun ev -> search_pos_window txt x:ev.ev_MouseX y:ev.ev_MouseY); + bind tw events:[`ButtonPressDetail 3] fields:[`MouseX;`MouseY] + action:(fun ev -> search_pos_menu txt x:ev.ev_MouseX y:ev.ev_MouseY); pack [sb] fill:`Y side:`Right; pack [tw] fill:`Both expand:true side:`Left; @@ -468,7 +468,7 @@ class editor :top :menus = object (self) with `yes -> self#save_text txt | `no -> () | `cancel -> raise Exit); - bind top events:[[],`Destroy] action:`Remove; + bind top events:[`Destroy]; destroy top; break () with Exit -> break () @@ -494,15 +494,14 @@ class editor :top :menus = object (self) [`Alt], "l", self#lex; [`Alt], "t", self#typecheck ] fun:begin fun (modi,key,act) -> - bind top events:[modi, `KeyPressDetail key] - action:(`Setbreakable ([], fun _ -> act (); break ())) + bind top events:[`Modified(modi, `KeyPressDetail key)] breakable:true + action:(fun _ -> act (); break ()) end; - bind top events:[[],`Destroy] - action:(`Setbreakable - ([`Widget], fun ev -> - if Widget.name ev.ev_Widget = Widget.name top - then self#quit ())); + bind top events:[`Destroy] breakable:true fields:[`Widget] + action:(fun ev -> + if Widget.name ev.ev_Widget = Widget.name top + then self#quit ()); (* File menu *) file_menu#add_command "Open File..." command:self#open_file; @@ -573,7 +572,7 @@ class editor :top :menus = object (self) pack (List.map fun:(fun m -> coe m#button) [file_menu; edit_menu; compiler_menu; module_menu; window_menu] @ [coe label]) - side:`Left ipadx:(`Pix 5) anchor:`W; + side:`Left ipadx:5 anchor:`W; pack [menus] before:(List.hd windows).frame side:`Top fill:`X end diff --git a/otherlibs/labltk/browser/fileselect.ml b/otherlibs/labltk/browser/fileselect.ml index ef6ce7bba..fd3a49814 100644 --- a/otherlibs/labltk/browser/fileselect.ml +++ b/otherlibs/labltk/browser/fileselect.ml @@ -83,7 +83,7 @@ let f :title action:proc ?(:dir = Unix.getcwd ()) and sync_var = new_var () in Textvariable.set filter_var to:deffilter; - let frm = Frame.create tl borderwidth:(`Pix 1) relief:`Raised in + let frm = Frame.create tl borderwidth:1 relief:`Raised in let df = Frame.create frm in let dfl = Frame.create df in let dfll = Label.create dfl text:"Directories" in @@ -93,7 +93,7 @@ let f :title action:proc ?(:dir = Unix.getcwd ()) let dfrl = Label.create dfr text:"Files" in let dfrf, filter_listbox, filter_scrollbar = Jg_box.create_with_scrollbar dfr in - let cfrm = Frame.create tl borderwidth:(`Pix 1) relief:`Raised in + let cfrm = Frame.create tl borderwidth:1 relief:`Raised in let configure :filter = let filter = @@ -179,8 +179,7 @@ let f :title action:proc ?(:dir = Unix.getcwd ()) Setpath.add_update_hook (fun () -> configure filter:!current_pattern); let w = Setpath.f dir:!current_dir in Grab.set w; - bind w events:[[], `Destroy] - action:(`Extend ([], fun _ -> Grab.set tl)) + bind w events:[`Destroy] extend:true action:(fun _ -> Grab.set tl) end in let toggle_in_path = Checkbutton.create dfl text:"Use load path" command: @@ -210,19 +209,18 @@ let f :title action:proc ?(:dir = Unix.getcwd ()) command:(fun () -> activate []) in (* binding *) - bind tl events:[[], `KeyPressDetail "Escape"] - action:(`Set ([], fun _ -> activate [])); + bind tl events:[`KeyPressDetail "Escape"] action:(fun _ -> activate []); Jg_box.add_completion filter_listbox action:(fun index -> activate [Listbox.get filter_listbox :index]); if multi then Listbox.configure filter_listbox selectmode:`Multiple else - bind filter_listbox events:[[], `ButtonPressDetail 1] - action:(`Set ([`MouseY], fun ev -> + bind filter_listbox events:[`ButtonPressDetail 1] fields:[`MouseY] + action:(fun ev -> let name = Listbox.get filter_listbox index:(Listbox.nearest filter_listbox y:ev.ev_MouseY) in if !load_in_path & usepath then try Textvariable.set selection_var to:(search_in_path :name) with Not_found -> () - else Textvariable.set selection_var to:(!current_dir ^ "/" ^ name))); + else Textvariable.set selection_var to:(!current_dir ^ "/" ^ name)); Jg_box.add_completion directory_listbox action: begin fun index -> diff --git a/otherlibs/labltk/browser/jg_bind.ml b/otherlibs/labltk/browser/jg_bind.ml index df0bf80d9..59dc89019 100644 --- a/otherlibs/labltk/browser/jg_bind.ml +++ b/otherlibs/labltk/browser/jg_bind.ml @@ -3,13 +3,12 @@ open Tk let enter_focus w = - bind w events:[[], `Enter] action:(`Set ([], fun _ -> Focus.set w)) + bind w events:[`Enter] action:(fun _ -> Focus.set w) let escape_destroy ?destroy:tl w = let tl = match tl with Some w -> w | None -> w in - bind w events:[[], `KeyPressDetail "Escape"] - action:(`Set ([], fun _ -> destroy tl)) + bind w events:[`KeyPressDetail "Escape"] action:(fun _ -> destroy tl) let return_invoke w :button = - bind w events:[[], `KeyPressDetail "Return"] - action:(`Set ([], fun _ -> Button.invoke button)) + bind w events:[`KeyPressDetail "Return"] + action:(fun _ -> Button.invoke button) diff --git a/otherlibs/labltk/browser/jg_box.ml b/otherlibs/labltk/browser/jg_box.ml index e7add1139..21a05829d 100644 --- a/otherlibs/labltk/browser/jg_box.ml +++ b/otherlibs/labltk/browser/jg_box.ml @@ -37,20 +37,22 @@ let add_completion ?:action ?:wait ?:nocase lb = Jg_bind.enter_focus lb; - bind lb events:[[], `KeyPress] - action:(`Set([`Char], fun ev -> + bind lb events:[`KeyPress] fields:[`Char] action: + begin fun ev -> (* consider only keys producing characters. The callback is called even if you press Shift. *) if ev.ev_Char <> "" then - recenter lb index:(`Num (comp#add ev.ev_Char)))); + recenter lb index:(`Num (comp#add ev.ev_Char)) + end; begin match action with Some action -> - bind lb events:[[], `KeyPressDetail "Return"] - action:(`Set ([], fun _ -> action `Active)); - bind lb events:[[`Double], `ButtonPressDetail 1] - action:(`Setbreakable ([`MouseY], fun ev -> - action (Listbox.nearest lb y:ev.ev_MouseY); break ())) + bind lb events:[`KeyPressDetail "Return"] + action:(fun _ -> action `Active); + bind lb events:[`Modified([`Double], `ButtonPressDetail 1)] + breakable:true fields:[`MouseY] + action:(fun ev -> + action (Listbox.nearest lb y:ev.ev_MouseY); break ()) | None -> () end; diff --git a/otherlibs/labltk/browser/jg_entry.ml b/otherlibs/labltk/browser/jg_entry.ml index b961d1a96..74bbf4723 100644 --- a/otherlibs/labltk/browser/jg_entry.ml +++ b/otherlibs/labltk/browser/jg_entry.ml @@ -6,8 +6,8 @@ let create ?:command ?:width ?:textvariable parent = let ew = Entry.create parent ?:width ?:textvariable in Jg_bind.enter_focus ew; begin match command with Some command -> - bind ew events:[[], `KeyPressDetail "Return"] - action:(`Set ([], fun _ -> command (Entry.get ew))) + bind ew events:[`KeyPressDetail "Return"] + action:(fun _ -> command (Entry.get ew)) | None -> () end; ew diff --git a/otherlibs/labltk/browser/jg_message.ml b/otherlibs/labltk/browser/jg_message.ml index 27b8f2eec..5d6bec930 100644 --- a/otherlibs/labltk/browser/jg_message.ml +++ b/otherlibs/labltk/browser/jg_message.ml @@ -61,8 +61,8 @@ let ask :title ?:master text = begin match master with None -> () | Some master -> Wm.transient_set tl :master end; - let mw = Message.create tl :text padx:(`Pix 20) pady:(`Pix 10) - width:(`Pix 250) justify:`Left aspect:400 anchor:`W + let mw = Message.create tl :text padx:20 pady:10 + width:250 justify:`Left aspect:400 anchor:`W and fw = Frame.create tl and sync = Textvariable.create on:tl () and r = ref (`cancel : [`yes|`no|`cancel]) in @@ -72,8 +72,8 @@ let ask :title ?:master text = command:(fun () -> r := `no; destroy tl) and cancel = Jg_button.create_destroyer tl parent:fw text:"Cancel" in - bind tl events:[[],`Destroy] - action:(`Extend([],fun _ -> Textvariable.set sync to:"1")); + bind tl events:[`Destroy] extend:true + action:(fun _ -> Textvariable.set sync to:"1"); pack [accept; refuse; cancel] side:`Left fill:`X expand:true; pack [mw] side:`Top fill:`Both; pack [fw] side:`Bottom fill:`X expand:true; diff --git a/otherlibs/labltk/browser/jg_multibox.ml b/otherlibs/labltk/browser/jg_multibox.ml index f7c1ec2c4..249127582 100644 --- a/otherlibs/labltk/browser/jg_multibox.ml +++ b/otherlibs/labltk/browser/jg_multibox.ml @@ -58,8 +58,8 @@ class c :cols :texts ?:maxheight ?:width parent = object (self) gen_list len:cols fun: begin fun () -> Listbox.create parent :height ?:width - highlightthickness:(`Pix 0) - borderwidth:(`Pix 1) + highlightthickness:0 + borderwidth:1 end val mutable current = 0 method cols = cols @@ -94,7 +94,7 @@ class c :cols :texts ?:maxheight ?:width parent = object (self) Listbox.insert box :texts index:`End end; pack boxes side:`Left expand:true fill:`Both; - self#bind_mouse events:[[],`ButtonPressDetail 1] + self#bind_mouse events:[`ButtonPressDetail 1] action:(fun _ index:n -> self#recenter n; break ()); let current_height () = let (top,bottom) = Listbox.yview_get (List.hd boxes) in @@ -111,7 +111,7 @@ class c :cols :texts ?:maxheight ?:width parent = object (self) "Home", (fun _ -> 0); "End", (fun _ -> List.length texts) ] fun:begin fun (key,f) -> - self#bind_kbd events:[[],`KeyPressDetail key] + self#bind_kbd events:[`KeyPressDetail key] action:(fun _ index:n -> self#recenter (f n); break ()) end; self#recenter 0 @@ -120,10 +120,10 @@ class c :cols :texts ?:maxheight ?:width parent = object (self) List.iter boxes fun: begin fun box -> let b = !i in - bind box :events - action:(`Setbreakable ([`MouseX;`MouseY], fun ev -> + bind box :events breakable:true fields:[`MouseX;`MouseY] + action:(fun ev -> let `Num n = Listbox.nearest box y:ev.ev_MouseY - in action ev index:(n * cols + b))); + in action ev index:(n * cols + b)); incr i end method bind_kbd :events :action = @@ -131,10 +131,10 @@ class c :cols :texts ?:maxheight ?:width parent = object (self) List.iter boxes fun: begin fun box -> let b = !i in - bind box :events - action:(`Setbreakable ([`Char], fun ev -> + bind box :events breakable:true fields:[`Char] + action:(fun ev -> let `Num n = Listbox.index box index:`Active in - action ev index:(n * cols + b))); + action ev index:(n * cols + b)); incr i end end @@ -151,7 +151,7 @@ let add_scrollbar (box : c) = let add_completion ?:action ?:wait (box : c) = let comp = new Jg_completion.timed (box#texts) ?:wait in - box#bind_kbd events:[[], `KeyPress] + box#bind_kbd events:[`KeyPress] action:(fun ev :index -> (* consider only keys producing characters. The callback is called * even if you press Shift. *) @@ -159,11 +159,11 @@ let add_completion ?:action ?:wait (box : c) = box#recenter (comp#add ev.ev_Char) aligntop:true); match action with Some action -> - box#bind_kbd events:[[], `KeyPressDetail "space"] + box#bind_kbd events:[`KeyPressDetail "space"] action:(fun ev :index -> action (box#current)); - box#bind_kbd events:[[], `KeyPressDetail "Return"] + box#bind_kbd events:[`KeyPressDetail "Return"] action:(fun ev :index -> action (box#current)); - box#bind_mouse events:[[], `ButtonPressDetail 1] + box#bind_mouse events:[`ButtonPressDetail 1] action:(fun ev :index -> box#recenter index; action (box#current); break ()) | None -> () diff --git a/otherlibs/labltk/browser/jg_multibox.mli b/otherlibs/labltk/browser/jg_multibox.mli index ea6539607..716ee7646 100644 --- a/otherlibs/labltk/browser/jg_multibox.mli +++ b/otherlibs/labltk/browser/jg_multibox.mli @@ -12,11 +12,9 @@ object method init : unit method recenter : ?aligntop:bool -> int -> unit method bind_mouse : - events:(Tk.modifier list * Tk.xEvent) list -> - action:(Tk.eventInfo -> index:int -> unit) -> unit + events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit method bind_kbd : - events:(Tk.modifier list * Tk.xEvent) list -> - action:(Tk.eventInfo -> index:int -> unit) -> unit + events:Tk.event list -> action:(Tk.eventInfo -> index:int -> unit) -> unit end val add_scrollbar : c -> Widget.scrollbar Widget.widget diff --git a/otherlibs/labltk/browser/main.ml b/otherlibs/labltk/browser/main.ml index 55aa4be2f..a519e2c0a 100644 --- a/otherlibs/labltk/browser/main.ml +++ b/otherlibs/labltk/browser/main.ml @@ -21,7 +21,7 @@ let _ = let top = openTk class:"OCamlBrowser" () in Jg_config.init (); - bind top events:[[], `Destroy] action:(`Set ([], fun _ -> exit 0)); + bind top events:[`Destroy] action:(fun _ -> exit 0); at_exit Shell.kill_all; diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 45df95474..f399f12a9 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -328,19 +328,20 @@ let rec view_signature ?:title ?:path ?(:env = !start_env) sign = Jg_text.tag_and_see tw start:(tpos s) end:(tpos e) tag:"error"; [] in Jg_bind.enter_focus tw; - bind tw events:[[`Control], `KeyPressDetail"s"] - action:(`Set ([], fun _ -> Jg_text.search_string tw)); - bind tw events:[[`Double], `ButtonPressDetail 1] - action:(`Setbreakable ([`MouseX;`MouseY], fun ev -> + bind tw events:[`Modified([`Control], `KeyPressDetail"s")] + action:(fun _ -> Jg_text.search_string tw); + bind tw events:[`Modified([`Double], `ButtonPressDetail 1)] + fields:[`MouseX;`MouseY] breakable:true + action:(fun ev -> let `Linechar (l, c) = Text.index tw index:(`Atxy(ev.ev_MouseX,ev.ev_MouseY), []) in try try search_pos_signature pt pos:(lines_to_chars l in:text + c) :env; break () with Found_sig (kind, lid, env) -> view_decl lid :kind :env - with Not_found | Env.Error _ -> ())); - bind tw events:[[], `ButtonPressDetail 3] - action:(`Setbreakable ([`MouseX;`MouseY], fun ev -> + with Not_found | Env.Error _ -> ()); + bind tw events:[`ButtonPressDetail 3] fields:[`MouseX;`MouseY] breakable:true + action:(fun ev -> let x = ev.ev_MouseX and y = ev.ev_MouseY in let `Linechar (l, c) = Text.index tw index:(`Atxy(x,y), []) in @@ -351,7 +352,7 @@ let rec view_signature ?:title ?:path ?(:env = !start_env) sign = let menu = view_decl_menu lid :kind :env parent:tw in let x = x + Winfo.rootx tw and y = y + Winfo.rooty tw - 10 in Menu.popup menu :x :y - with Not_found -> ())) + with Not_found -> ()) and view_signature_item sign :path :env = view_signature sign title:(string_of_path path) ?path:(parent_path path) :env diff --git a/otherlibs/labltk/browser/setpath.ml b/otherlibs/labltk/browser/setpath.ml index 8094b82e0..e35efc6a7 100644 --- a/otherlibs/labltk/browser/setpath.ml +++ b/otherlibs/labltk/browser/setpath.ml @@ -88,19 +88,18 @@ let f :dir = renew_dirs dirbox var:var_dir dir:!current_dir end; - bind dir_name events:[[],`KeyPressDetail"Return"] - action:(`Set([], fun _ -> + bind dir_name events:[`KeyPressDetail"Return"] + action:(fun _ -> let dir = Textvariable.get var_dir in if Useunix.is_directory dir then begin current_dir := dir; renew_dirs dirbox var:var_dir :dir - end)); - + end); +(* let bind_space_toggle lb = - bind lb events:[[], `KeyPressDetail "space"] - action:(`Extend ([], fun _ -> ())) + bind lb events:[`KeyPressDetail "space"] extend:true action:ignore in bind_space_toggle dirbox; bind_space_toggle pathbox; - +*) let add_paths _ = add_to_path pathbox base:!current_dir dirs:(List.map (Listbox.curselection dirbox) @@ -111,10 +110,8 @@ let f :dir = dirs:(List.map (Listbox.curselection pathbox) fun:(fun x -> Listbox.get pathbox index:x)) in - bind dirbox events:[[], `KeyPressDetail "Insert"] - action:(`Set ([], add_paths)); - bind pathbox events:[[], `KeyPressDetail "Delete"] - action:(`Set ([], remove_paths)); + bind dirbox events:[`KeyPressDetail "Insert"] action:add_paths; + bind pathbox events:[`KeyPressDetail "Delete"] action:remove_paths; let dirlab = Label.create dirs text:"Directories" and pathlab = Label.create path text:"Load path" @@ -131,16 +128,16 @@ let f :dir = pack [dirbox] side:`Left fill:`Y expand:true; pack [pathsb] side:`Right fill:`Y; pack [pathbox] side:`Left fill:`Both expand:true; - pack [dirlab] side:`Top anchor:`W padx:(`Pix 10); + pack [dirlab] side:`Top anchor:`W padx:10; pack [addbutton] side:`Bottom fill:`X; pack [dirframe] fill:`Y expand:true; - pack [pathlab] side:`Top anchor:`W padx:(`Pix 10); + pack [pathlab] side:`Top anchor:`W padx:10; pack [removebutton; ok] side:`Left fill:`X expand:true; pack [pathbuttons] fill:`X side:`Bottom; pack [pathframe] fill:`Both expand:true; pack [dirs] side:`Left fill:`Y; pack [path] side:`Right fill:`Both expand:true; - pack [caplab] side:`Top anchor:`W padx:(`Pix 10); + pack [caplab] side:`Top anchor:`W padx:10; pack [dir_name] side:`Top anchor:`W fill:`X; pack [browse] side:`Bottom expand:true fill:`Both; tl diff --git a/otherlibs/labltk/browser/shell.ml b/otherlibs/labltk/browser/shell.ml index 3378c1a20..7fc557c32 100644 --- a/otherlibs/labltk/browser/shell.ml +++ b/otherlibs/labltk/browser/shell.ml @@ -121,22 +121,23 @@ object (self) initializer Lexical.init_tags textw; let rec bindings = - [ ([[],`KeyPress],[`Char],fun ev -> self#keypress ev.ev_Char); - ([[],`KeyRelease],[`Char],fun ev -> self#keyrelease ev.ev_Char); - (* [[],`KeyPressDetail"Return"],[],fun _ -> self#return; *) - ([[],`ButtonPressDetail 2], [`MouseX; `MouseY], self#paste); - ([[`Alt],`KeyPressDetail"p"],[],fun _ -> self#history `previous); - ([[`Alt],`KeyPressDetail"n"],[],fun _ -> self#history `next); - ([[`Meta],`KeyPressDetail"p"],[],fun _ -> self#history `previous); - ([[`Meta],`KeyPressDetail"n"],[],fun _ -> self#history `next); - ([[`Control],`KeyPressDetail"c"],[],fun _ -> self#interrupt); - ([[],`Destroy],[],fun _ -> self#kill) ] + [ ([], `KeyPress, [`Char], fun ev -> self#keypress ev.ev_Char); + ([], `KeyRelease, [`Char], fun ev -> self#keyrelease ev.ev_Char); + (* [], `KeyPressDetail"Return", [], fun _ -> self#return; *) + ([], `ButtonPressDetail 2, [`MouseX; `MouseY], self#paste); + ([`Alt], `KeyPressDetail"p", [], fun _ -> self#history `previous); + ([`Alt], `KeyPressDetail"n", [], fun _ -> self#history `next); + ([`Meta], `KeyPressDetail"p", [], fun _ -> self#history `previous); + ([`Meta], `KeyPressDetail"n", [], fun _ -> self#history `next); + ([`Control], `KeyPressDetail"c", [], fun _ -> self#interrupt); + ([], `Destroy, [], fun _ -> self#kill) ] in - List.iter bindings - fun:(fun (events,fields,f) -> - bind textw :events action:(`Set(fields,f))); - bind textw events:[[],`KeyPressDetail"Return"] - action:(`Setbreakable([], fun _ -> self#return; break())); + List.iter bindings fun: + begin fun (modif,event,fields,action) -> + bind textw events:[`Modified(modif,event)] :fields :action + end; + bind textw events:[`KeyPressDetail"Return"] breakable:true + action:(fun _ -> self#return; break()); begin try List.iter [in1;err1] fun: begin fun fd -> @@ -184,7 +185,7 @@ let f :prog :title = and signal_menu = new Jg_menu.c "Signal" parent:menus in pack [menus] side:`Top fill:`X; pack [file_menu#button; history_menu#button; signal_menu#button] - side:`Left ipadx:(`Pix 5) anchor:`W; + side:`Left ipadx:5 anchor:`W; let frame, tw, sb = Jg_text.create_with_scrollbar tl in Text.configure tw background:`White; pack [sb] fill:`Y side:`Right; diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml index 8d90681a2..ea2c1a7b6 100644 --- a/otherlibs/labltk/browser/typecheck.ml +++ b/otherlibs/labltk/browser/typecheck.ml @@ -84,8 +84,8 @@ let f txt = else begin error_messages := tl :: !error_messages; Text.configure ew state:`Disabled; - bind ew events:[[`Double], `ButtonPressDetail 1] - action:(`Set ([], fun _ -> + bind ew events:[`Modified([`Double], `ButtonPressDetail 1)] + action:(fun _ -> let s = Text.get ew start:(`Mark "insert", [`Wordstart]) end:(`Mark "insert", [`Wordend]) in @@ -93,6 +93,6 @@ let f txt = let n = int_of_string s in Text.mark_set txt.tw index:(tpos n) mark:"insert"; Text.see txt.tw index:(`Mark "insert", []) - with Failure "int_of_string" -> ())) + with Failure "int_of_string" -> ()) end; !error_messages diff --git a/otherlibs/labltk/browser/viewer.ml b/otherlibs/labltk/browser/viewer.ml index 12e03a021..7f82d3686 100644 --- a/otherlibs/labltk/browser/viewer.ml +++ b/otherlibs/labltk/browser/viewer.ml @@ -72,7 +72,7 @@ let choose_symbol :title :env ?:signature ?:path l = Jg_bind.escape_destroy tl; top_widgets := coe tl :: !top_widgets; let buttons = Frame.create tl in - let all = Button.create buttons text:"Show all" padx:(`Pix 20) + let all = Button.create buttons text:"Show all" padx:20 and ok = Jg_button.create_destroyer tl parent:buttons and detach = Button.create buttons text:"Detach" and edit = Button.create buttons text:"Impl" @@ -89,7 +89,7 @@ let choose_symbol :title :env ?:signature ?:path l = let box = new Jg_multibox.c fb cols:3 texts:nl maxheight:3 width:21 in box#init; - box#bind_kbd events:[[],`KeyPressDetail"Escape"] + box#bind_kbd events:[`KeyPressDetail"Escape"] action:(fun _ :index -> destroy tl; break ()); if List.length nl > 9 then (Jg_multibox.add_scrollbar box; ()); Jg_multibox.add_completion box action: @@ -270,8 +270,7 @@ let f ?(:dir=Unix.getcwd()) ?:on () = let ew = Entry.create tl in let buttons = Frame.create tl in - let search = Button.create buttons text:"Search" pady:(`Pix 1) - command: + let search = Button.create buttons text:"Search" pady:1 command: begin fun () -> let s = Entry.get ew in let is_type = ref false and is_long = ref false in @@ -293,14 +292,13 @@ let f ?(:dir=Unix.getcwd()) ?:on () = | _ -> choose_symbol title:"Choose symbol" env:!start_env l end and close = - Button.create buttons text:"Close all" pady:(`Pix 1) - command:close_all_views + Button.create buttons text:"Close all" pady:1 command:close_all_views in (* bindings *) Jg_bind.enter_focus ew; Jg_bind.return_invoke ew button:search; - bind close events:[[`Double], `ButtonPressDetail 1] - action:(`Set ([], fun _ -> destroy tl)); + bind close events:[`Modified([`Double], `ButtonPressDetail 1)] + action:(fun _ -> destroy tl); (* File menu *) filemenu#add_command "Open..." @@ -315,7 +313,7 @@ let f ?(:dir=Unix.getcwd()) ?:on () = command:(fun () -> reset_modules mbox; Env.reset_cache ()); modmenu#add_command "Search symbol..." command:search_symbol; - pack [filemenu#button; modmenu#button] side:`Left ipadx:(`Pix 5) anchor:`W; + pack [filemenu#button; modmenu#button] side:`Left ipadx:5 anchor:`W; pack [menus] side:`Top fill:`X; pack [close; search] fill:`X side:`Right expand:true; pack [coe buttons; coe ew] fill:`X side:`Bottom; diff --git a/otherlibs/labltk/builtin/builtin_bind.ml b/otherlibs/labltk/builtin/builtin_bind.ml index d8923353a..bb7cca965 100644 --- a/otherlibs/labltk/builtin/builtin_bind.ml +++ b/otherlibs/labltk/builtin/builtin_bind.ml @@ -3,7 +3,7 @@ open Widget (* Events and bindings *) (* Builtin types *) (* type *) -type xEvent = [ +type event = [ `ButtonPress (* also Button, but we omit it *) | `ButtonPressDetail (int) | `ButtonRelease @@ -27,12 +27,11 @@ type xEvent = [ | `Property | `Reparent | `Unmap - | `Visibility + | `Visibility + | `Modified modifier list * event ] -(* /type *) -(* type *) -type modifier = [ +and modifier = [ `Control | `Shift | `Lock @@ -121,7 +120,7 @@ type eventField = [ ] (* /type *) -let filleventInfo ev v = function +let filleventInfo ev v : eventField -> unit = function `Above -> ev.ev_Above <- int_of_string v | `ButtonNumber -> ev.ev_ButtonNumber <- int_of_string v | `Count -> ev.ev_Count <- int_of_string v @@ -149,7 +148,7 @@ let filleventInfo ev v = function | `RootX -> ev.ev_RootX <- int_of_string v | `RootY -> ev.ev_RootY <- int_of_string v -let wrapeventInfo f what = +let wrapeventInfo f (what : eventField list) = let ev = { ev_Above = 0; ev_ButtonNumber = 0; @@ -188,7 +187,7 @@ let wrapeventInfo f what = -let rec writeeventField = function +let rec writeeventField : eventField list -> string = function [] -> "" | field::rest -> begin @@ -217,20 +216,8 @@ let rec writeeventField = function | `RootWindow ->" %R" | `SubWindow -> " %S" | `Type -> " %T" - | `Widget ->" %W" + | `Widget -> " %W" | `RootX -> " %X" | `RootY -> " %Y" end ^ writeeventField rest - - -(* type *) -type bindAction = [ - `Set ( eventField list * (eventInfo -> unit)) - | `Setbreakable ( eventField list * (eventInfo -> unit) ) - | `Remove - | `Extend ( eventField list * (eventInfo -> unit)) -] -(* /type *) - - diff --git a/otherlibs/labltk/builtin/builtinf_GetPixel.ml b/otherlibs/labltk/builtin/builtinf_GetPixel.ml new file mode 100644 index 000000000..78735d513 --- /dev/null +++ b/otherlibs/labltk/builtin/builtinf_GetPixel.ml @@ -0,0 +1,6 @@ +let pixels units = +let res = tkEval [|TkToken"winfo"; + TkToken"pixels"; + cCAMLtoTKwidget default_toplevel; + cCAMLtoTKunits units|] in +int_of_string res diff --git a/otherlibs/labltk/builtin/builtinf_bind.ml b/otherlibs/labltk/builtin/builtinf_bind.ml index b05219143..7a3e1e770 100644 --- a/otherlibs/labltk/builtin/builtinf_bind.ml +++ b/otherlibs/labltk/builtin/builtinf_bind.ml @@ -1,77 +1,32 @@ -(* -FUNCTION - val bind: - any widget -> (modifier list * xEvent) list -> bindAction -> unit -/FUNCTION -*) -let bind widget events:eventsequence action:(action : bindAction) = - tkEval [| TkToken "bind"; - TkToken (Widget.name widget); - cCAMLtoTKeventSequence eventsequence; - begin match action with - `Remove -> TkToken "" - | `Set (what, f) -> - let cbId = register_callback widget callback: (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | `Setbreakable (what, f) -> - let cbId = register_callback widget callback: (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" - ) - | `Extend (what, f) -> - let cbId = register_callback widget callback: (wrapeventInfo f what) in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - - end - |]; - () - -(* -FUNCTION -(* unsafe *) - val class_bind : - string -> (modifier list * xEvent) list -> bindAction -> unit -(* /unsafe *) -/FUNCTION - class arg is not constrained -*) -let class_bind clas events:eventsequence action:(action : bindAction) = - tkEval [| TkToken "bind"; - TkToken clas; - cCAMLtoTKeventSequence eventsequence; - begin match action with - `Remove -> TkToken "" - | `Set (what, f) -> - let cbId = register_callback Widget.dummy - callback: (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | `Setbreakable (what, f) -> - let cbId = register_callback Widget.dummy - callback: (wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" - ) - | `Extend (what, f) -> - let cbId = register_callback Widget.dummy - callback: (wrapeventInfo f what) in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - +let bind_class :events ?(:extend = false) ?(:breakable = false) ?(:fields = []) + ?:action ?(on:widget) name = + let widget = match widget with None -> Widget.dummy | Some w -> coe w in + ignore begin + tkEval + [| TkToken "bind"; + TkToken name; + cCAMLtoTKeventSequence events; + begin match action with None -> TkToken "" + | Some f -> + let cbId = + register_callback widget callback: (wrapeventInfo f fields) in + let cb = if extend then "+camlcb " else "camlcb " in + let cb = cb ^ cbId ^ writeeventField fields in + let cb = + if breakable then + cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" + ^ " ; set BreakBindingsSequence 0" + else cb in + TkToken cb + end + |] end - |]; - () -(* -FUNCTION -(* unsafe *) - val tag_bind : - string -> (modifier list * xEvent) list -> bindAction -> unit -(* /unsafe *) -/FUNCTION - tag name arg is not constrained -*) - -let tag_bind = class_bind +let bind :events ?:extend ?:breakable ?:fields ?:action widget = + bind_class :events ?:extend ?:breakable ?:fields ?:action on:widget + (Widget.name widget) +let bind_tag = bind_class (* FUNCTION @@ -79,5 +34,6 @@ FUNCTION /FUNCTION *) let break = function () -> - tkEval [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |]; - () + ignore begin + tkEval [| TkToken "set" ; TkToken "BreakBindingsSequence" ; TkToken "1" |] + end diff --git a/otherlibs/labltk/builtin/builtini_GetPixel.ml b/otherlibs/labltk/builtin/builtini_GetPixel.ml index e47048aec..7f1983e4f 100644 --- a/otherlibs/labltk/builtin/builtini_GetPixel.ml +++ b/otherlibs/labltk/builtin/builtini_GetPixel.ml @@ -4,7 +4,6 @@ let cCAMLtoTKunits : units -> tkArgs = function | `In (foo) -> TkToken(string_of_float foo^"i") | `Pt (foo) -> TkToken(string_of_float foo^"p") | `Cm (foo) -> TkToken(string_of_float foo^"c") - let cTKtoCAMLunits str = let len = String.length str in diff --git a/otherlibs/labltk/builtin/builtini_bind.ml b/otherlibs/labltk/builtin/builtini_bind.ml index 1cba2d1a9..ffce51833 100644 --- a/otherlibs/labltk/builtin/builtini_bind.ml +++ b/otherlibs/labltk/builtin/builtini_bind.ml @@ -1,4 +1,24 @@ -let cCAMLtoTKxEvent : xEvent -> string = function +let cCAMLtoTKmodifier : modifier -> string = function + `Control -> "Control-" + | `Shift -> "Shift-" + | `Lock -> "Lock-" + | `Button1 -> "Button1-" + | `Button2 -> "Button2-" + | `Button3 -> "Button3-" + | `Button4 -> "Button4-" + | `Button5 -> "Button5-" + | `Double -> "Double-" + | `Triple -> "Triple-" + | `Mod1 -> "Mod1-" + | `Mod2 -> "Mod2-" + | `Mod3 -> "Mod3-" + | `Mod4 -> "Mod4-" + | `Mod5 -> "Mod5-" + | `Meta -> "Meta-" + | `Alt -> "Alt-" + +let cCAMLtoTKevent (ev : event) = + let rec convert = function `ButtonPress -> "ButtonPress" | `ButtonPressDetail n -> "ButtonPress-"^string_of_int n | `ButtonRelease -> "ButtonRelease" @@ -22,37 +42,13 @@ let cCAMLtoTKxEvent : xEvent -> string = function | `Property -> "Property" | `Reparent -> "Reparent" | `Unmap -> "Unmap" - | `Visibility -> "Visibility" - -let cCAMLtoTKmodifier : modifier -> string = function - `Control -> "Control-" - | `Shift -> "Shift-" - | `Lock -> "Lock-" - | `Button1 -> "Button1-" - | `Button2 -> "Button2-" - | `Button3 -> "Button3-" - | `Button4 -> "Button4-" - | `Button5 -> "Button5-" - | `Double -> "Double-" - | `Triple -> "Triple-" - | `Mod1 -> "Mod1-" - | `Mod2 -> "Mod2-" - | `Mod3 -> "Mod3-" - | `Mod4 -> "Mod4-" - | `Mod5 -> "Mod5-" - | `Meta -> "Meta-" - | `Alt -> "Alt-" - + | `Visibility -> "Visibility" + | `Modified(ml, ev) -> + String.concat sep:"" (List.map fun:cCAMLtoTKmodifier ml) + ^ convert ev + in "<" ^ convert ev ^ ">" -(* type event = modifier list * xEvent *) -let cCAMLtoTKevent : (modifier list * xEvent) -> string = - function (ml, xe) -> - "<" ^ (String.concat sep:" " (List.map fun:cCAMLtoTKmodifier ml)) - ^ (cCAMLtoTKxEvent xe) ^ ">" - -(* type eventSequence == (modifier list * xEvent) list *) -let cCAMLtoTKeventSequence : (modifier list * xEvent) list -> tkArgs = - function l -> +let cCAMLtoTKeventSequence (l : event list) = TkToken(String.concat sep:"" (List.map fun:cCAMLtoTKevent l)) diff --git a/otherlibs/labltk/builtin/builtini_text.ml b/otherlibs/labltk/builtin/builtini_text.ml index e3ca25602..e14c1a952 100644 --- a/otherlibs/labltk/builtin/builtini_text.ml +++ b/otherlibs/labltk/builtin/builtini_text.ml @@ -5,33 +5,26 @@ let cCAMLtoTKtextTag x = TkToken x let cTKtoCAMLtextTag x = x (* TextModifiers are never returned by Tk *) -let ppTextModifier = function - `Char n -> - if n > 0 then "+" ^ (string_of_int n) ^ "chars" - else if n = 0 then "" - else (string_of_int n) ^ "chars" - | `Line n -> - if n > 0 then "+" ^ (string_of_int n) ^ "lines" - else if n = 0 then "" - else (string_of_int n) ^ "lines" - | `Linestart -> " linestart" - | `Lineend -> " lineend" - | `Wordstart -> " wordstart" - | `Wordend -> " wordend" - -(* -let ppTextIndex = function - `None -> "" - | `Index (base, ml) -> - let (TkToken ppbase) = cCAMLtoTKtext_index base in - String.concat sep:"" (ppbase :: List.map fun:ppTextModifier ml) -*) - -let ppTextIndex = function - (base, ml) -> - let (TkToken ppbase) = cCAMLtoTKtext_index base in - String.concat sep:"" (ppbase :: List.map fun:ppTextModifier ml) - -let cCAMLtoTKtextIndex : textIndex -> tkArgs = function i -> +let cCAMLtoTKtextIndex (i : textIndex) = + let ppTextModifier = function + `Char n -> + if n > 0 then "+" ^ (string_of_int n) ^ "chars" + else if n = 0 then "" + else (string_of_int n) ^ "chars" + | `Line n -> + if n > 0 then "+" ^ (string_of_int n) ^ "lines" + else if n = 0 then "" + else (string_of_int n) ^ "lines" + | `Linestart -> " linestart" + | `Lineend -> " lineend" + | `Wordstart -> " wordstart" + | `Wordend -> " wordend" + in + let ppTextIndex (base, ml : textIndex) = + match cCAMLtoTKtext_index base with + TkToken ppbase -> + String.concat sep:"" (ppbase :: List.map fun:ppTextModifier ml) + | _ -> assert false + in TkToken (ppTextIndex i) diff --git a/otherlibs/labltk/builtin/canvas_bind.ml b/otherlibs/labltk/builtin/canvas_bind.ml index 43f07dcb7..ed646fe47 100644 --- a/otherlibs/labltk/builtin/canvas_bind.ml +++ b/otherlibs/labltk/builtin/canvas_bind.ml @@ -1,21 +1,23 @@ -let bind widget :tag events:eventsequence :action = - tkEval [| cCAMLtoTKwidget widget; - TkToken "bind"; - cCAMLtoTKtagOrId tag; - cCAMLtoTKeventSequence eventsequence; - begin match action with - `Remove -> TkToken "" - | `Set (what, f) -> - let cbId = register_callback widget callback:(wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | `Setbreakable (what, f) -> - let cbId = register_callback widget callback:(wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" - ) - | `Extend (what, f) -> - let cbId = register_callback widget callback:(wrapeventInfo f what) in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) - - end |]; - () +let bind :tag :events ?(:extend = false) ?(:breakable = false) ?(:fields = []) + ?:action widget = + ignore begin + tkEval + [| cCAMLtoTKwidget widget; + TkToken "bind"; + cCAMLtoTKtagOrId tag; + cCAMLtoTKeventSequence events; + begin match action with None -> TkToken "" + | Some f -> + let cbId = + register_callback widget callback: (wrapeventInfo f fields) in + let cb = if extend then "+camlcb " else "camlcb " in + let cb = cb ^ cbId ^ writeeventField fields in + let cb = + if breakable then + cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" + ^ " ; set BreakBindingsSequence 0" + else cb in + TkToken cb + end + |] + end diff --git a/otherlibs/labltk/builtin/canvas_bind.mli b/otherlibs/labltk/builtin/canvas_bind.mli index 55c3ec364..ca26aef44 100644 --- a/otherlibs/labltk/builtin/canvas_bind.mli +++ b/otherlibs/labltk/builtin/canvas_bind.mli @@ -1,2 +1,4 @@ -val bind : canvas widget -> tag: tagOrId -> - events: (modifier list * xEvent) list -> action: bindAction -> unit +val bind : + tag: tagOrId -> events: event list -> + ?extend: bool -> ?breakable: bool -> ?fields: eventField list -> + ?action: (eventInfo -> unit) -> canvas widget -> unit diff --git a/otherlibs/labltk/builtin/selection_handle_set.ml b/otherlibs/labltk/builtin/selection_handle_set.ml index 33a2baec0..f773a7a6d 100644 --- a/otherlibs/labltk/builtin/selection_handle_set.ml +++ b/otherlibs/labltk/builtin/selection_handle_set.ml @@ -3,8 +3,7 @@ let handle_set command: cmd = selection_handle_icccm_optionals (fun opts w -> tkEval [|TkToken"selection"; TkToken"handle"; - TkTokenList - (List.map opts fun:(cCAMLtoTKselection_handle_icccm w)); + TkTokenList opts; cCAMLtoTKwidget w; let id = register_callback w callback:(function args -> let a1 = int_of_string (List.hd args) in diff --git a/otherlibs/labltk/builtin/selection_own_set.ml b/otherlibs/labltk/builtin/selection_own_set.ml index d851b85dc..22b2af52f 100644 --- a/otherlibs/labltk/builtin/selection_own_set.ml +++ b/otherlibs/labltk/builtin/selection_own_set.ml @@ -3,11 +3,7 @@ let own_set ?:command = selection_ownset_icccm_optionals ?:command (fun opts w -> tkEval [|TkToken"selection"; TkToken"own"; - TkTokenList - (List.map - fun:(function x -> - cCAMLtoTKselection_ownset_icccm w x) - opts); + TkTokenList opts; cCAMLtoTKwidget w|]; ()) diff --git a/otherlibs/labltk/builtin/text_tag_bind.ml b/otherlibs/labltk/builtin/text_tag_bind.ml index 2abb30a18..ac23bc2e3 100644 --- a/otherlibs/labltk/builtin/text_tag_bind.ml +++ b/otherlibs/labltk/builtin/text_tag_bind.ml @@ -1,22 +1,24 @@ -let tag_bind widget :tag events:eventsequence :action = - tkEval [| cCAMLtoTKwidget widget; - TkToken "tag"; - TkToken "bind"; - cCAMLtoTKtextTag tag; - cCAMLtoTKeventSequence eventsequence; - begin match action with - `Remove -> TkToken "" - | `Set (what, f) -> - let cbId = register_callback widget callback:(wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)) - | `Setbreakable (what, f) -> - let cbId = register_callback widget callback:(wrapeventInfo f what) in - TkToken ("camlcb " ^ cbId ^ (writeeventField what)^ - " ; if { $BreakBindingsSequence == 1 } then { break ;} ; set BreakBindingsSequence 0" - ) - | `Extend (what, f) -> - let cbId = register_callback widget callback:(wrapeventInfo f what) in - TkToken ("+camlcb " ^ cbId ^ (writeeventField what)) +let tag_bind :tag :events ?(:extend = false) ?(:breakable = false) + ?(:fields = []) ?:action widget = + ignore begin + tkEval + [| cCAMLtoTKwidget widget; + TkToken "tag"; + TkToken "bind"; + cCAMLtoTKtextTag tag; + cCAMLtoTKeventSequence events; + begin match action with None -> TkToken "" + | Some f -> + let cbId = + register_callback widget callback: (wrapeventInfo f fields) in + let cb = if extend then "+camlcb " else "camlcb " in + let cb = cb ^ cbId ^ writeeventField fields in + let cb = + if breakable then + cb ^ " ; if { $BreakBindingsSequence == 1 } then { break ;}" + ^ " ; set BreakBindingsSequence 0" + else cb in + TkToken cb + end + |] end - |]; - () diff --git a/otherlibs/labltk/builtin/text_tag_bind.mli b/otherlibs/labltk/builtin/text_tag_bind.mli index c78a35e62..40b969926 100644 --- a/otherlibs/labltk/builtin/text_tag_bind.mli +++ b/otherlibs/labltk/builtin/text_tag_bind.mli @@ -1,2 +1,4 @@ -val tag_bind: text widget -> tag:textTag -> - events:(modifier list * xEvent) list -> action: bindAction -> unit +val tag_bind : + tag: string -> events: event list -> + ?extend: bool -> ?breakable: bool -> ?fields: eventField list -> + ?action: (eventInfo -> unit) -> text widget -> unit diff --git a/otherlibs/labltk/compiler/compile.ml b/otherlibs/labltk/compiler/compile.ml index a7f46168d..13bd115e6 100644 --- a/otherlibs/labltk/compiler/compile.ml +++ b/otherlibs/labltk/compiler/compile.ml @@ -4,7 +4,7 @@ open Tables (* CONFIGURE *) (* if you set it true, ImagePhoto and ImageBitmap will annoy you... *) -let safetype = false +let safetype = true let labeloff :at l = match l with "",t -> t @@ -221,37 +221,13 @@ let write_variants :w = function (* Definition of a type *) let write_type intf:w impl:w' name def:typdef = -(* if typdef.subtypes = [] then (* If there is no subtypes *) - begin - (* The type itself *) - (* Put markers for extraction *) - w "(* type *)\n"; - w ("type "^name^" =\n "); - write_constructors :w (sort_components typdef.constructors); - w "\n(* /type *)\n\n" - end - else -*) - begin - if typdef.subtypes = [] then - begin - w "(* Variant type *)\n"; - w ("type "^name^" = [\n "); - write_variants :w (sort_components typdef.constructors); - w "\n]\n\n" - end - else - begin - (* Dynamic Subtyping *) - (* All the subtypes *) - List.iter typdef.subtypes fun: - begin fun (s,l) -> - w ("type "^s^"_"^name^" = [\n "); - write_variants w:w (sort_components l); - w ("]\n\n") - end - end - end + (* Only needed if no subtypes, otherwise use optionals *) + if typdef.subtypes = [] then begin + w "(* Variant type *)\n"; + w ("type "^name^" = [\n "); + write_variants :w (sort_components typdef.constructors); + w "\n]\n\n" + end (************************************************************) (* Converters *) @@ -447,12 +423,6 @@ let rec converterCAMLtoTK :context_widget argname as:ty = | UserDefined s -> let name = "cCAMLtoTK"^s^" " in let args = argname in -(* - let args = - if is_subtyped s then (* unconstraint subtype *) - s^"_any_table "^args - else args in -*) let args = if requires_widget_context s then context_widget^" "^args @@ -461,20 +431,11 @@ let rec converterCAMLtoTK :context_widget argname as:ty = | Subtype ("widget",s') -> let name = "cCAMLtoTKwidget" in let args = "("^argname^" : "^s'^" widget)" in -(* - let args = - if requires_widget_context s then - context_widget^" "^args - else args in -*) name^args | Subtype (s,s') -> let name = "cCAMLtoTK"^s'^"_"^s^" " in - let args = if safetype then "("^argname^" : "^s'^"_"^s^")" else argname + let args = if safetype then "("^argname^" : #"^s'^"_"^s^")" else argname in -(* - let args = s^"_"^s'^"_table "^argname in -*) let args = if requires_widget_context s then context_widget^" "^args @@ -521,8 +482,7 @@ let code_of_template :context_widget ?(func:funtemplate=false) template = let lbl = gettklabel (List.hd classdef) in catch_opts := (sub^"_"^sup, lbl); newvar := newvar2; - "TkTokenList (List.map fun:(function x -> " - ^ converterCAMLtoTK :context_widget "x" as:ty ^ ") opts)" + "TkTokenList opts" | TypeArg (l,List ty) -> "TkTokenList (List.map fun:(function x -> " ^ converterCAMLtoTK :context_widget "x" as:ty @@ -600,20 +560,30 @@ let write_CAMLtoTK :w def:typdef ?(safetype:st = true) name = end else "dummy" in - if safetype && st then - w (" : " ^ name ^ " -> tkArgs "); + if st then begin + w " : "; + if typdef.variant then w "#"; + w name; w " -> tkArgs " + end; w(" = function\n "); write_clause :w :context_widget (List.hd constrs); List.iter (List.tl constrs) fun:(fun c -> w "\n | "; write_clause :w :context_widget c); w "\n\n\n" in - if typdef.subtypes == [] then - write_one name typdef.constructors - else - List.iter typdef.subtypes fun:begin - fun (subname,constrs) -> - write_one (subname^"_"^name) constrs + (* Only needed if no subtypes, otherwise use optionals *) + if typdef.subtypes == [] then + write_one name typdef.constructors + else + List.iter typdef.constructors fun: + begin fun fc -> + let code, vars, _, (co, _) = + code_of_template context_widget:"dummy" fc.template in + if co <> "" then fatal_error "optionals in optionals"; + let vars = List.map fun:snd vars in + w "let ccCAMLtoTK"; w name; w "_"; w (small fc.ml_name); + w " ("; w (String.concat sep:"," vars); w ") =\n "; + w code; w "\n\n" end (* Tcl does not really return "lists". It returns sp separated tokens *) @@ -700,12 +670,12 @@ let write_function :w def = let write_create :w clas = (w "let create ?:name =\n" : unit); - w (" "^ clas ^ "_options_optionals (fun options parent ->\n"); + w (" "^ clas ^ "_options_optionals (fun opts parent ->\n"); w (" let w = new_atom \"" ^ clas ^ "\" :parent ?:name in\n"); w " tkEval [|"; w ("TkToken \"" ^ clas ^ "\";\n"); w (" TkToken (Widget.name w);\n"); - w (" TkTokenList (List.map fun:(cCAMLtoTK" ^ clas ^ "_options dummy) options) |];\n"); + w (" TkTokenList opts |];\n"); w (" w)\n\n\n") (* builtin-code: the file (without suffix) is in .template... *) @@ -725,58 +695,39 @@ let write_external :w def = | _ -> raise (Compiler_Error "invalid external definition") let write_catch_optionals :w clas def:typdef = - if typdef.subtypes = [] then - (* begin Printf.eprintf "No subtypes\n";() end *) () - else - (* Printf.eprintf "Type constructors of %s\n" clas; *) + if typdef.subtypes = [] then () else List.iter typdef.subtypes fun: begin fun (subclass, classdefs) -> -(* - Printf.eprintf "Subclass %s" subclass; - List.iter (fun fc -> - Printf.eprintf " %s\n" fc.ml_name) classdefs; -*) w ("let " ^ subclass ^"_"^ clas ^ "_optionals f = fun\n"); let tklabels = List.map fun:gettklabel classdefs in let l = List.map classdefs fun: begin fun fc -> - List.length (types_of_template fc.template), - types_of_template fc.template, - (* used as names of variants *) - fc.var_name, - begin let p = gettklabel fc in - if count key:p tklabels > 1 then small fc.ml_name else p - end, - small_ident fc.ml_name (* used as labels *) + (* + let code, vars, _, (co, _) = + code_of_template context_widget:"dummy" fc.template in + if co <> "" then fatal_error "optionals in optionals"; + *) + let p = gettklabel fc in + (if count key:p tklabels > 1 then small fc.ml_name else p), + small_ident fc.ml_name (* used as labels *), + small fc.ml_name end in let p = List.map l fun: - begin fun (_,_,_,s,si) -> + begin fun (s, si, _) -> if s = si then " ?:" ^ s else " ?" ^ s ^ ":" ^ si end in let v = List.map l fun: - begin fun (i,t,c,s,si) -> - let vars = - if i = 0 then "()" else - if i = 1 then "x" - else - let s = ref [] in - for i=1 to i do - s := !s @ ["x" ^ string_of_int i] - done; - "(" ^ String.concat sep:"," !s ^ ")" - in - let apvars = - if i = 0 then "" - (* VERY VERY QUICK HACK FOR 'a widget -> any widget *) - else if i = 1 && vars = "x" && t = ["",UserDefined "widget"] then - "(forget_type x)" - else vars - in - "(maycons (fun " ^ vars ^ " -> " ^ "`" ^ c ^ " " ^ apvars ^ ") " ^ si + begin fun (_, si, s) -> + (* + let vars = List.map fun:snd vars in + let vars = String.concat sep:"," vars in + "(maycons (fun (" ^ vars ^ ") -> " ^ code ^ ") " ^ si + *) + "(maycons ccCAMLtoTK" ^ clas ^ "_" ^ s ^ " " ^ si end in w (String.concat sep:"\n" p); w " ->\n"; diff --git a/otherlibs/labltk/example/calc.ml b/otherlibs/labltk/example/calc.ml index ca87ef59e..fe1485689 100644 --- a/otherlibs/labltk/example/calc.ml +++ b/otherlibs/labltk/example/calc.ml @@ -80,7 +80,7 @@ let m = class calculator :parent = object inherit calc () as calc - val label = Label.create anchor:`E relief:`Sunken padx:(`Pix 10) parent + val label = Label.create anchor:`E relief:`Sunken padx:10 parent val frame = Frame.create parent initializer @@ -93,8 +93,8 @@ class calculator :parent = object in Label.configure textvariable:variable label; calc#set to:"0"; - bind parent events:[[],`KeyPress] - action:(`Set([`Char],fun ev -> calc#command ev.ev_Char)); + bind parent events:[`KeyPress] fields:[`Char] + action:(fun ev -> calc#command ev.ev_Char); for i = 0 to Array.length m - 1 do Grid.configure row:i buttons.(i) done; diff --git a/otherlibs/labltk/example/clock.ml b/otherlibs/labltk/example/clock.ml index 7e8e25cf7..53847e35e 100644 --- a/otherlibs/labltk/example/clock.ml +++ b/otherlibs/labltk/example/clock.ml @@ -21,21 +21,20 @@ let pi = acos (-1.) class clock :parent = object (self) (* Instance variables *) - val canvas = Canvas.create parent width:(`Pix 100) height:(`Pix 100) + val canvas = Canvas.create parent width:100 height:100 val mutable height = 100 val mutable width = 100 val mutable rflag = -1 (* Convert from -1.0 .. 1.0 to actual positions on the canvas *) - method x x0 = `Pix (truncate (float width *. (x0 +. 1.) /. 2.)) - method y y0 = `Pix (truncate (float height *. (y0 +. 1.) /. 2.)) + method x x0 = truncate (float width *. (x0 +. 1.) /. 2.) + method y y0 = truncate (float height *. (y0 +. 1.) /. 2.) initializer (* Create the oval border *) Canvas.create_oval canvas tags:[`Tag "cadran"] - x1:(`Pix 1) y1:(`Pix 1) - x2:(`Pix (width - 2)) y2:(`Pix (height - 2)) - width:(`Pix 3) outline:(`Yellow) fill:`White; + x1:1 y1:1 x2:(width - 2) y2:(height - 2) + width:3 outline:`Yellow fill:`White; (* Draw the figures *) self#draw_figures; (* Create the arrows with dummy position *) @@ -51,22 +50,21 @@ class clock :parent = object (self) Timer.add ms:1000 callback:timer; () in timer (); (* Redraw when configured (changes size) *) - bind canvas events:[[],`Configure] - action:(`Set ([], fun _ -> + bind canvas events:[`Configure] + action:(fun _ -> width <- Winfo.width canvas; height <- Winfo.height canvas; - self#redraw)); + self#redraw); (* Change direction with right button *) - bind canvas events:[[],`ButtonPressDetail 3] - action:(`Set ([], fun _ -> rflag <- -rflag; self#redraw)); + bind canvas events:[`ButtonPressDetail 3] + action:(fun _ -> rflag <- -rflag; self#redraw); (* Pack, expanding in both directions *) pack [canvas] fill:`Both expand:true (* Redraw everything *) method redraw = Canvas.coords_set canvas tag:(`Tag "cadran") - coords:[ `Pix 1; `Pix 1; - `Pix (width - 2); `Pix (height - 2) ]; + coords:[ 1; 1; width - 2; height - 2 ]; self#draw_figures; self#draw_arrows (Unix.localtime (Unix.time ())) @@ -85,7 +83,7 @@ class clock :parent = object (self) (* Resize and reposition the arrows *) method draw_arrows tm = Canvas.configure_line canvas tag:(`Tag "hours") - width:(`Pix (min width height / 40)); + width:(min width height / 40); let hangle = float (rflag * (tm.Unix.tm_hour * 60 + tm.Unix.tm_min) - 180) *. pi /. 360. in @@ -93,7 +91,7 @@ class clock :parent = object (self) coords:[ self#x 0.; self#y 0.; self#x (cos hangle /. 2.); self#y (sin hangle /. 2.) ]; Canvas.configure_line canvas tag:(`Tag "minutes") - width:(`Pix (min width height / 50)); + width:(min width height / 50); let mangle = float (rflag * tm.Unix.tm_min - 15) *. pi /. 30. in Canvas.coords_set canvas tag:(`Tag "minutes") coords:[ self#x 0.; self#y 0.; diff --git a/otherlibs/labltk/example/demo.ml b/otherlibs/labltk/example/demo.ml index 2e72f386d..e91d0cad3 100644 --- a/otherlibs/labltk/example/demo.ml +++ b/otherlibs/labltk/example/demo.ml @@ -16,8 +16,7 @@ let base = Frame.create top in pack [base]; (* Menu bar *) -let bar = - Frame.create base borderwidth: (`Pix 2) relief: `Raised in +let bar = Frame.create base borderwidth: 2 relief: `Raised in pack [bar] fill: `X; (* Menu and Menubutton *) @@ -39,11 +38,11 @@ pack [bar] fill: `X; let but = Button.create left text: "Welcome to LablTk" in (* Canvas *) - let can = Canvas.create left width: (`Pix 100) - height: (`Pix 100) borderwidth: (`Pix 1) relief: `Sunken + let can = Canvas.create left width: 100 + height: 100 borderwidth: 1 relief: `Sunken in - Canvas.create_oval can x1:(`Pix 10) y1:(`Pix 10) - x2:(`Pix 90) y2:(`Pix 90) + Canvas.create_oval can x1: 10 y1: 10 + x2: 90 y2: 90 fill:`Red; (* Check button *) @@ -72,7 +71,7 @@ pack [bar] fill: `X; ["One"; "Two"; "Three"] in (* Scale *) - let sca = Scale.create right label: "Scale" length: (`Pix 100) + let sca = Scale.create right label: "Scale" length: 100 showvalue: true in (* Text and scrollbar *) @@ -109,10 +108,8 @@ pack [bar] fill: `X; let buttons = List.map fun:(fun (w, t, c, a) -> let b = Button.create top2 text:t command:c in - bind b events: [[], `Enter] - action:(`Set ([], fun _ -> a selcol)); - bind b events: [[], `Leave] - action:(`Set ([], fun _ -> a defcol)); + bind b events: [`Enter] action:(fun _ -> a selcol); + bind b events: [`Leave] action:(fun _ -> a defcol); b) [coe bar, "Frame", (fun () -> ()), (fun background -> Frame.configure bar :background); diff --git a/otherlibs/labltk/example/eyes.ml b/otherlibs/labltk/example/eyes.ml index 9640d4682..f77765a5e 100644 --- a/otherlibs/labltk/example/eyes.ml +++ b/otherlibs/labltk/example/eyes.ml @@ -4,36 +4,35 @@ let _ = let top = openTk () in let fw = Frame.create top in pack [fw]; - let c = Canvas.create fw width: (`Pix 200) height: (`Pix 200) in + let c = Canvas.create fw width: 200 height: 200 in let create_eye cx cy wx wy ewx ewy bnd = - let o2 = Canvas.create_oval c - x1:(`Pix (cx - wx)) y1:(`Pix (cy - wy)) - x2:(`Pix (cx + wx)) y2:(`Pix (cy + wy)) - outline: (`Color "black") width: (`Pix 7) - fill: (`Color "white") + let o2 = Canvas.create_oval c + x1:(cx - wx) y1:(cy - wy) + x2:(cx + wx) y2:(cy + wy) + outline: `Black width: 7 + fill: `White and o = Canvas.create_oval c - x1:(`Pix (cx - ewx)) y1:(`Pix (cy - ewy)) - x2:(`Pix (cx + ewx)) y2:(`Pix (cy + ewy)) - fill: (`Color "black") in + x1:(cx - ewx) y1:(cy - ewy) + x2:(cx + ewx) y2:(cy + ewy) + fill:`Black in let curx = ref cx and cury = ref cy in - bind c events:[[], `Motion] - action: (`Extend ([`MouseX; `MouseY], (fun e -> - let nx, ny = - let xdiff = e.ev_MouseX - cx - and ydiff = e.ev_MouseY - cy in - let diff = sqrt (((float xdiff) /. ((float wx) *. bnd)) ** 2.0 +. - ((float ydiff) /. ((float wy) *. bnd)) ** 2.0) in - if diff > 1.0 then - truncate ((float xdiff) *. (1.0 /. diff)) + cx, - truncate ((float ydiff) *. (1.0 /. diff)) + cy - else - e.ev_MouseX, e.ev_MouseY + bind c events:[`Motion] extend:true fields:[`MouseX; `MouseY] + action:(fun e -> + let nx, ny = + let xdiff = e.ev_MouseX - cx + and ydiff = e.ev_MouseY - cy in + let diff = sqrt ((float xdiff /. (float wx *. bnd)) ** 2.0 +. + (float ydiff /. (float wy *. bnd)) ** 2.0) in + if diff > 1.0 then + truncate ((float xdiff) *. (1.0 /. diff)) + cx, + truncate ((float ydiff) *. (1.0 /. diff)) + cy + else + e.ev_MouseX, e.ev_MouseY in - Canvas.move c tag: o - x: (`Pix (nx - !curx)) y: (`Pix (ny - !cury)); - curx := nx; - cury := ny))) + Canvas.move c tag: o x: (nx - !curx) y: (ny - !cury); + curx := nx; + cury := ny) in create_eye 60 100 30 40 5 6 0.6; create_eye 140 100 30 40 5 6 0.6; diff --git a/otherlibs/labltk/example/tetris.ml b/otherlibs/labltk/example/tetris.ml index f4ee99828..0b95e1087 100644 --- a/otherlibs/labltk/example/tetris.ml +++ b/otherlibs/labltk/example/tetris.ml @@ -198,14 +198,14 @@ class cell t1 t2 t3 :canvas :x :y = object if color = col then () else if color <> 0 & col = 0 then begin Canvas.move canvas tag: t1 - x:(`Pix (- block_size * (x + 1) -10 - cell_border * 2)) - y:(`Pix (- block_size * (y + 1) -10 - cell_border * 2)); + x:(- block_size * (x + 1) -10 - cell_border * 2) + y:(- block_size * (y + 1) -10 - cell_border * 2); Canvas.move canvas tag: t2 - x:(`Pix (- block_size * (x + 1) -10 - cell_border * 2)) - y:(`Pix (- block_size * (y + 1) -10 - cell_border * 2)); + x:(- block_size * (x + 1) -10 - cell_border * 2) + y:(- block_size * (y + 1) -10 - cell_border * 2); Canvas.move canvas tag: t3 - x:(`Pix (- block_size * (x + 1) -10 - cell_border * 2)) - y:(`Pix (- block_size * (y + 1) -10 - cell_border * 2)) + x:(- block_size * (x + 1) -10 - cell_border * 2) + y:(- block_size * (y + 1) -10 - cell_border * 2) end else begin Canvas.configure_rectangle canvas tag: t2 fill: colors.(col - 1) @@ -218,14 +218,14 @@ class cell t1 t2 t3 :canvas :x :y = object outline: (`Color "light gray"); if color = 0 & col <> 0 then begin Canvas.move canvas tag: t1 - x: (`Pix (block_size * (x+1)+10+ cell_border*2)) - y: (`Pix (block_size * (y+1)+10+ cell_border*2)); + x: (block_size * (x+1)+10+ cell_border*2) + y: (block_size * (y+1)+10+ cell_border*2); Canvas.move canvas tag: t2 - x: (`Pix (block_size * (x+1)+10+ cell_border*2)) - y: (`Pix (block_size * (y+1)+10+ cell_border*2)); + x: (block_size * (x+1)+10+ cell_border*2) + y: (block_size * (y+1)+10+ cell_border*2); Canvas.move canvas tag: t3 - x: (`Pix (block_size * (x+1)+10+ cell_border*2)) - y: (`Pix (block_size * (y+1)+10+ cell_border*2)) + x: (block_size * (x+1)+10+ cell_border*2) + y: (block_size * (y+1)+10+ cell_border*2) end end; color <- col @@ -251,19 +251,19 @@ let init fw = and levv = Textvariable.create () and namev = Textvariable.create () in - let f = Frame.create fw borderwidth: (`Pix 2) in - let c = Canvas.create f width: (`Pix (block_size * 10)) - height: (`Pix (block_size * 20)) - borderwidth: (`Pix cell_border) + let f = Frame.create fw borderwidth: 2 in + let c = Canvas.create f width: (block_size * 10) + height: (block_size * 20) + borderwidth: cell_border relief: `Sunken background: `Black and r = Frame.create f and r' = Frame.create f in let nl = Label.create r text: "Next" font: "variable" in - let nc = Canvas.create r width: (`Pix (block_size * 4)) - height: (`Pix (block_size * 4)) - borderwidth: (`Pix cell_border) + let nc = Canvas.create r width: (block_size * 4) + height: (block_size * 4) + borderwidth: cell_border relief: `Sunken background: `Black in let scl = Label.create r text: "Score" font: "variable" in @@ -287,16 +287,16 @@ let init fw = begin fun (x,y) -> let t1 = Canvas.create_rectangle c - x1:(`Pix (-block_size - 8)) y1:(`Pix (-block_size - 8)) - x2:(`Pix (-9)) y2:(`Pix (-9)) + x1:(-block_size - 8) y1:(-block_size - 8) + x2:(-9) y2:(-9) and t2 = Canvas.create_rectangle c - x1:(`Pix (-block_size - 10)) y1:(`Pix (-block_size - 10)) - x2:(`Pix (-11)) y2:(`Pix (-11)) + x1:(-block_size - 10) y1:(-block_size - 10) + x2:(-11) y2:(-11) and t3 = Canvas.create_rectangle c - x1:(`Pix (-block_size - 12)) y1:(`Pix (-block_size - 12)) - x2:(`Pix (-13)) y2:(`Pix (-13)) + x1:(-block_size - 12) y1:(-block_size - 12) + x2:(-13) y2:(-13) in Canvas.raise c tag: t1; Canvas.raise c tag: t2; @@ -311,16 +311,16 @@ let init fw = begin fun (x,y) -> let t1 = Canvas.create_rectangle nc - x1:(`Pix (-block_size - 8)) y1:(`Pix (-block_size - 8)) - x2:(`Pix (-9)) y2:(`Pix (-9)) + x1:(-block_size - 8) y1:(-block_size - 8) + x2:(-9) y2:(-9) and t2 = Canvas.create_rectangle nc - x1:(`Pix (-block_size - 10)) y1:(`Pix (-block_size - 10)) - x2:(`Pix (-11)) y2:(`Pix (-11)) + x1:(-block_size - 10) y1:(-block_size - 10) + x2:(-11) y2:(-11) and t3 = Canvas.create_rectangle nc - x1:(`Pix (-block_size - 12)) y1:(`Pix (-block_size - 12)) - x2:(`Pix (-13)) y2:(`Pix (-13)) + x1:(-block_size - 12) y1:(-block_size - 12) + x2:(-13) y2:(-13) in Canvas.raise nc tag: t1; Canvas.raise nc tag: t2; @@ -532,8 +532,8 @@ let _ = let image_load = let i = Canvas.create_image canvas - x: (`Pix (block_size * 5 + block_size / 2)) - y: (`Pix (block_size * 10 + block_size / 2)) + x: (block_size * 5 + block_size / 2) + y: (block_size * 10 + block_size / 2) anchor: `Center in Canvas.lower canvas tag: i; let img = Imagephoto.create () in @@ -621,48 +621,48 @@ let _ = in let bind_game w = - bind w events:[[],`KeyPress] action:(`Set ([`KeySymString], - fun e -> - begin match e.ev_KeySymString with - | "h" -> - let m = copy_block current in - m.x <- m.x - 1; - try_to_move m; () - | "j" -> - let m = copy_block current in - m.d <- m.d + 1; - if m.d = List.length m.pattern then m.d <- 0; - try_to_move m; () - | "k" -> - let m = copy_block current in - m.d <- m.d - 1; - if m.d < 0 then m.d <- List.length m.pattern - 1; - try_to_move m; () - | "l" -> - let m = copy_block current in - m.x <- m.x + 1; - try_to_move m; () - | "m" -> - remove_timer (); - loop () - | "space" -> - if !current.alive then - begin - let m = copy_block current - and n = copy_block current in - while - m.y <- m.y + 1; - if death_check m then false - else begin n.y <- m.y; true end - do () done; - erase_falling_block !current; - draw_falling_block n; - current := n; - remove_timer (); - loop () - end - | _ -> () - end)) + bind w events:[`KeyPress] fields:[`KeySymString] action: + begin fun e -> + match e.ev_KeySymString with + | "h" -> + let m = copy_block current in + m.x <- m.x - 1; + try_to_move m; () + | "j" -> + let m = copy_block current in + m.d <- m.d + 1; + if m.d = List.length m.pattern then m.d <- 0; + try_to_move m; () + | "k" -> + let m = copy_block current in + m.d <- m.d - 1; + if m.d < 0 then m.d <- List.length m.pattern - 1; + try_to_move m; () + | "l" -> + let m = copy_block current in + m.x <- m.x + 1; + try_to_move m; () + | "m" -> + remove_timer (); + loop () + | "space" -> + if !current.alive then + begin + let m = copy_block current + and n = copy_block current in + while + m.y <- m.y + 1; + if death_check m then false + else begin n.y <- m.y; true end + do () done; + erase_falling_block !current; + draw_falling_block n; + current := n; + remove_timer (); + loop () + end + | _ -> () + end in let game_init () = diff --git a/otherlibs/labltk/jpf/balloon.ml b/otherlibs/labltk/jpf/balloon.ml index 9278124e3..3115812ef 100644 --- a/otherlibs/labltk/jpf/balloon.ml +++ b/otherlibs/labltk/jpf/balloon.ml @@ -55,29 +55,14 @@ let put on: w ms: millisec mesg = configure_cursor w "hand2")) in - List.iter fun: (fun x -> - bind w events: x action: (`Extend ([], (fun _ -> -(* begin - match x with - [[],Leave] -> prerr_endline " LEAVE reset " - | _ -> prerr_endline " Other reset " - end; -*) - reset ())))) - [[[], `Leave]; [[], `ButtonPress]; [[], `ButtonRelease]; [[], `Destroy]; - [[], `KeyPress]; [[], `KeyRelease]]; - List.iter fun: (fun x -> - bind w events:x action: (`Extend ([`RootX; `RootY], (fun ev -> -(* - begin - match x with - [[],Enter] -> prerr_endline " Enter set " - | [[],Motion] -> prerr_endline " Motion set " - | _ -> prerr_endline " ??? set " - end; -*) - reset (); set ev)))) - [[[], `Enter]; [[], `Motion]] + List.iter [[`Leave]; [`ButtonPress]; [`ButtonRelease]; [`Destroy]; + [`KeyPress]; [`KeyRelease]] + fun:(fun events -> bind w :events extend:true action:(fun _ -> reset ())); + List.iter [[`Enter]; [`Motion]] fun: + begin fun events -> + bind w :events extend:true fields:[`RootX; `RootY] + action:(fun ev -> reset (); set ev) + end let init () = let t = Hashtbl.create 101 in @@ -89,12 +74,11 @@ let init () = popupw := Message.create !topw name: "balloon" background: (`Color "yellow") aspect: 300; pack [!popupw]; - class_bind "all" - events: [[], `Enter] action: (`Extend ([`Widget], (function w -> - try Hashtbl.find t key: w.ev_Widget with - Not_found -> begin + bind_class "all" events: [`Enter] extend:true fields:[`Widget] action: + begin fun w -> + try Hashtbl.find t key: w.ev_Widget + with Not_found -> Hashtbl.add t key:w.ev_Widget data: (); let x = Option.get w.ev_Widget name: "balloon" class: "Balloon" in if x <> "" then put on: w.ev_Widget ms: 1000 x - end))) - + end diff --git a/otherlibs/labltk/jpf/fileselect.ml b/otherlibs/labltk/jpf/fileselect.ml index 42e69b453..45acccb5f 100644 --- a/otherlibs/labltk/jpf/fileselect.ml +++ b/otherlibs/labltk/jpf/fileselect.ml @@ -24,8 +24,7 @@ let scroll_link sb lb = (* focus when enter binding *) let bind_enter_focus w = - bind w events: [[], `Enter] - action: (`Set ([], fun _ -> Focus.set w));; + bind w events:[`Enter] action:(fun _ -> Focus.set w);; let myentry_create p :variable = let w = Entry.create p relief: `Sunken textvariable: variable in @@ -146,15 +145,12 @@ let add_completion lb action = recenter() in - bind lb events:[[], `KeyPress] - action: (`Set([`Char; `Time], - (function ev -> - (* consider only keys producing characters. The callback is called - * even if you press Shift. - *) - if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char))); + bind lb events:[`KeyPress] fields:[`Char; `Time] + (* consider only keys producing characters. The callback is called + if you press Shift. *) + action:(fun ev -> if ev.ev_Char <> "" then complete ev.ev_Time ev.ev_Char); (* Key specific bindings override KeyPress *) - bind lb events:[[], `KeyPressDetail "Return"] action:(`Set([], action)); + bind lb events:[`KeyPressDetail "Return"] :action; (* Finally, we have to set focus, otherwise events dont get through *) Focus.set lb; recenter() (* so that first item is selected *); @@ -184,8 +180,8 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync = and selection_var = Textvariable.create on:tl () and sync_var = Textvariable.create on:tl () in - let frm' = Frame.create tl borderwidth: (`Pix 1) relief: `Raised in - let frm = Frame.create frm' borderwidth: (`Pix 8) in + let frm' = Frame.create tl borderwidth: 1 relief: `Raised in + let frm = Frame.create frm' borderwidth: 8 in let fl = Label.create frm text: "Filter" in let df = Frame.create frm in let dfl = Frame.create df in @@ -204,8 +200,8 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync = let filter_entry = myentry_create frm variable: filter_var in let selection_entry = myentry_create frm variable: selection_var in - let cfrm' = Frame.create tl borderwidth: (`Pix 1) relief: `Raised in - let cfrm = Frame.create cfrm' borderwidth: (`Pix 8) in + let cfrm' = Frame.create tl borderwidth: 1 relief: `Raised in + let cfrm = Frame.create cfrm' borderwidth: 8 in let dumf = Frame.create cfrm in let dumf2 = Frame.create cfrm in @@ -281,11 +277,10 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync = command: (fun () -> activate [] ()) in (* binding *) - bind selection_entry events:[[], `KeyPressDetail "Return"] - action:(`Setbreakable ([], fun _ -> - activate [Textvariable.get selection_var] () )); - bind filter_entry events:[[], `KeyPressDetail "Return"] action:(`Set ([], - fun _ -> configure (Textvariable.get filter_var) )); + bind selection_entry events:[`KeyPressDetail "Return"] breakable:true + action:(fun _ -> activate [Textvariable.get selection_var] ()); + bind filter_entry events:[`KeyPressDetail "Return"] + action:(fun _ -> configure (Textvariable.get filter_var)); let action _ = let files = @@ -294,8 +289,8 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync = in activate files () in - bind filter_listbox events:[[`Double], `ButtonPressDetail 1] - action:(`Setbreakable ([], action)); + bind filter_listbox events:[`Modified([`Double], `ButtonPressDetail 1)] + breakable:true :action; if multi then Listbox.configure filter_listbox selectmode: `Multiple; filter_init_completion := add_completion filter_listbox action; @@ -307,8 +302,8 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync = Bell.ring (); raise Not_selected) (Listbox.curselection directory_listbox)) ^ "/" ^ !current_pattern) with _ -> () in - bind directory_listbox events:[[`Double], `ButtonPressDetail 1] - action:(`Setbreakable ([], action)); + bind directory_listbox events:[`Modified([`Double], `ButtonPressDetail 1)] + breakable:true :action; Listbox.configure directory_listbox selectmode: `Browse; directory_init_completion := add_completion directory_listbox action; @@ -317,7 +312,7 @@ let f :title action:proc filter:deffilter file:deffile :multi :sync = pack [fl] side: `Top anchor: `W; pack [filter_entry] side: `Top fill: `X; (* directory + files *) - pack [df] side: `Top fill: `X ipadx: (`Pix 8); + pack [df] side: `Top fill: `X ipadx: 8; (* directory *) pack [dfl] side: `Left; pack [dfll] side: `Top anchor: `W; |