From bfcc3811a3ce55cafa6f7809d0d92c87238ea032 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Thu, 15 Sep 2016 03:41:54 +1000 Subject: Menu callbacks working, also some quick testing code that'll probably get deleted later because wynaut --- src/adapad.adb | 35 +++++++- src/callback_test.adb | 56 +++++++++++++ src/editors.adb | 20 ++++- src/editors.ads | 19 +++-- src/fltk_binding/c_fl_menu.cpp | 4 +- src/fltk_binding/c_fl_menu.h | 3 + src/fltk_binding/c_fl_menu_item.cpp | 17 ---- src/fltk_binding/c_fl_menu_item.h | 15 ---- src/fltk_binding/fltk-callbacks.adb | 15 ---- src/fltk_binding/fltk-callbacks.ads | 21 ----- src/fltk_binding/fltk-menu_items.adb | 108 ------------------------- src/fltk_binding/fltk-menu_items.ads | 89 --------------------- src/fltk_binding/fltk-widgets-menus.adb | 136 ++++++++++++++++++++++++++++++-- src/fltk_binding/fltk-widgets-menus.ads | 86 +++++++++++++++++--- src/fltk_binding/fltk-widgets.ads | 1 + 15 files changed, 330 insertions(+), 295 deletions(-) create mode 100644 src/callback_test.adb delete mode 100644 src/fltk_binding/c_fl_menu_item.cpp delete mode 100644 src/fltk_binding/c_fl_menu_item.h delete mode 100644 src/fltk_binding/fltk-callbacks.adb delete mode 100644 src/fltk_binding/fltk-callbacks.ads delete mode 100644 src/fltk_binding/fltk-menu_items.adb delete mode 100644 src/fltk_binding/fltk-menu_items.ads (limited to 'src') diff --git a/src/adapad.adb b/src/adapad.adb index 7aab4af..2f4c483 100644 --- a/src/adapad.adb +++ b/src/adapad.adb @@ -5,19 +5,50 @@ with Editors; use Editors; with FLTK.Text_Buffers; use FLTK.Text_Buffers; --- with FLTK.Widgets.Menus.Menu_Bars; +with FLTK.Widgets; +use FLTK.Widgets; +with FLTK.Widgets.Menus; +use FLTK.Widgets.Menus; + + +with Ada.Text_IO; function AdaPad return Integer is - Pad : Editor_Window := Create (0, 0, 640, 400, "AdaPad"); + Pad : aliased Editor_Window := Create (0, 0, 640, 400, "AdaPad"); Buffer : Text_Buffer := Create; + type Editor_Callback is abstract new Widget_Callback with + record + Editor : access Editor_Window; + end record; + + + type Open_Callback is new Editor_Callback with null record; + Open_CB : aliased Open_Callback := (Editor => Pad'Access); + + + overriding procedure Call + (This : in Open_Callback; + Item : in out Widget'Class) is + begin + Ada.Text_IO.Put_Line ("Open callback executed."); + end Call; + + begin + declare + Bar : Menu_Cursor := Pad.Get_Menu; + begin + Bar.Add ("File/Open", Open_CB'Access); + end; + + Pad.Set_Buffer (Buffer); Pad.Show; return FLTK.Run; diff --git a/src/callback_test.adb b/src/callback_test.adb new file mode 100644 index 0000000..9abd734 --- /dev/null +++ b/src/callback_test.adb @@ -0,0 +1,56 @@ + + +with FLTK.Widgets; +use FLTK.Widgets; +with FLTK.Widgets.Buttons; +use FLTK.Widgets.Buttons; +with FLTK.Widgets.Groups.Windows; +use FLTK.Widgets.Groups.Windows; +with Ada.Text_IO; +with Ada.Strings.Unbounded; +use Ada.Strings.Unbounded; + + +function Callback_Test return Integer is + + + Main_View : Window := Create (0, 0, 300, 300, "Tester"); + Pusher : Button := Create (75, 75, 150, 150, "Push me"); + + + type My_Callback is new Widget_Callback with + record + Msg : Unbounded_String; + end record; + + SC : aliased My_Callback := (Msg => To_Unbounded_String ("Hello!")); + OC : aliased My_Callback := (Msg => To_Unbounded_String ("And again!")); + + overriding procedure Call + (This : in My_Callback; + Item : in out Widget'Class) is + begin + Ada.Text_IO.Put_Line ("Pushed a button :O"); + Ada.Text_IO.Put_Line (To_String (This.Msg)); + if This.Msg = "Hello!" then + Item.Set_Callback (OC'Access); + Item.Set_Label ("Push me again!"); + else + Item.Set_Callback (SC'Access); + Item.Set_Label ("Push me"); + end if; + end Call; + + +begin + + + Main_View.Add (Pusher); + Pusher.Set_Callback (SC'Access); + Main_View.Show; + + return FLTK.Run; + + +end Callback_Test; + diff --git a/src/editors.adb b/src/editors.adb index 3cdfa5f..9400016 100644 --- a/src/editors.adb +++ b/src/editors.adb @@ -10,8 +10,10 @@ package body Editors is begin return This : Editor_Window := (Double_Window'(Create (X, Y, W, H, Label_Text)) with - The_Editor => Text_Editor'(Create (0, 30, 640, 370, ""))) do - This.Add (This.The_Editor); + Editor => Text_Editor'(Create (0, 30, 640, 370, "")), + Bar => Menu_Bar'(Create (0, 0, 640, 30, ""))) do + This.Add (This.Editor); + This.Add (This.Bar); end return; end Create; @@ -32,7 +34,7 @@ package body Editors is (This : in Editor_Window) return Text_Buffer_Cursor is begin - return This.The_Editor.Get_Buffer; + return This.Editor.Get_Buffer; end Get_Buffer; @@ -42,9 +44,19 @@ package body Editors is (This : in out Editor_Window; Buff : in out Text_Buffer) is begin - This.The_Editor.Set_Buffer (Buff); + This.Editor.Set_Buffer (Buff); end Set_Buffer; + + + function Get_Menu + (This : in out Editor_Window) + return Menu_Cursor is + begin + return Ref : Menu_Cursor (This.Bar'Access); + end Get_Menu; + + end Editors; diff --git a/src/editors.ads b/src/editors.ads index 9dde658..fb8b7ae 100644 --- a/src/editors.ads +++ b/src/editors.ads @@ -4,6 +4,10 @@ with FLTK.Widgets.Groups.Windows.Double; use FLTK.Widgets.Groups.Windows.Double; with FLTK.Widgets.Groups.Text_Displays.Text_Editors; use FLTK.Widgets.Groups.Text_Displays.Text_Editors; +with FLTK.Widgets.Menus; +use FLTK.Widgets.Menus; +with FLTK.Widgets.Menus.Menu_Bars; +use FLTK.Widgets.Menus.Menu_Bars; with FLTK.Text_Buffers; use FLTK.Text_Buffers; @@ -35,19 +39,18 @@ package Editors is Buff : in out Text_Buffer); + function Get_Menu + (This : in out Editor_Window) + return Menu_Cursor; + + private type Editor_Window is new Double_Window with record - -- Replace_Dialog : Window; - -- Replace_Find : Input; - -- Replace_With : Input; - -- Replace_All : Button; - -- Replace_Next : Enter_Button; - -- Replace_Cancel : Button; - - The_Editor : Text_Editor := Text_Editor'(Create (0, 30, 640, 370, "AdaPad")); + Bar : aliased Menu_Bar; + Editor : Text_Editor; end record; diff --git a/src/fltk_binding/c_fl_menu.cpp b/src/fltk_binding/c_fl_menu.cpp index 457d4f1..e8cbe58 100644 --- a/src/fltk_binding/c_fl_menu.cpp +++ b/src/fltk_binding/c_fl_menu.cpp @@ -4,5 +4,7 @@ #include "c_fl_menu.h" -// wheeee, placeholders +int fl_menu_add(MENU m, const char * t, unsigned long s, void * c, void * u, unsigned long f) { + return reinterpret_cast(m)->add(t, s, reinterpret_cast(c), u, f); +} diff --git a/src/fltk_binding/c_fl_menu.h b/src/fltk_binding/c_fl_menu.h index 691277e..d8e8b90 100644 --- a/src/fltk_binding/c_fl_menu.h +++ b/src/fltk_binding/c_fl_menu.h @@ -7,5 +7,8 @@ typedef void* MENU; +extern "C" int fl_menu_add(MENU m, const char * t, unsigned long s, void * c, void * u, unsigned long f); + + #endif diff --git a/src/fltk_binding/c_fl_menu_item.cpp b/src/fltk_binding/c_fl_menu_item.cpp deleted file mode 100644 index 7c2a38c..0000000 --- a/src/fltk_binding/c_fl_menu_item.cpp +++ /dev/null @@ -1,17 +0,0 @@ - - -#include -#include "c_fl_menu_item.h" - - -MENUITEM new_fl_menu_item(char* label, void* c, unsigned long k, unsigned short f) { - Fl_Menu_Item *m = new Fl_Menu_Item; - m->add(label, k, reinterpret_cast(c), 0, f); - return m; -} - - -void free_fl_menu_item(MENUITEM m) { - delete reinterpret_cast(m); -} - diff --git a/src/fltk_binding/c_fl_menu_item.h b/src/fltk_binding/c_fl_menu_item.h deleted file mode 100644 index 94e5903..0000000 --- a/src/fltk_binding/c_fl_menu_item.h +++ /dev/null @@ -1,15 +0,0 @@ - - -#ifndef FL_MENU_ITEM_GUARD -#define FL_MENU_ITEM_GUARD - - -typedef void* MENUITEM; - - -extern "C" MENUITEM new_fl_menu_item(char* label, void* c, unsigned long k, unsigned short f); -extern "C" void free_fl_menu_item(MENUITEM m); - - -#endif - diff --git a/src/fltk_binding/fltk-callbacks.adb b/src/fltk_binding/fltk-callbacks.adb deleted file mode 100644 index 193509b..0000000 --- a/src/fltk_binding/fltk-callbacks.adb +++ /dev/null @@ -1,15 +0,0 @@ - - -package body FLTK.Callbacks is - - - function Create - (Call : access procedure) - return Callback is - begin - return This : Callback; - end Create; - - -end FLTK.Callbacks; - diff --git a/src/fltk_binding/fltk-callbacks.ads b/src/fltk_binding/fltk-callbacks.ads deleted file mode 100644 index 4428c44..0000000 --- a/src/fltk_binding/fltk-callbacks.ads +++ /dev/null @@ -1,21 +0,0 @@ - - -package FLTK.Callbacks is - - - type Callback is private; - - - function Create - (Call : access procedure) - return Callback; - - -private - - - type Callback is null record; - - -end FLTK.Callbacks; - diff --git a/src/fltk_binding/fltk-menu_items.adb b/src/fltk_binding/fltk-menu_items.adb deleted file mode 100644 index 254de5f..0000000 --- a/src/fltk_binding/fltk-menu_items.adb +++ /dev/null @@ -1,108 +0,0 @@ - - -with Interfaces.C; -with System; -use type System.Address; - - -package body FLTK.Menu_Items is - - - function Shortcut - (Key : Pressable_Key) - return Shortcut_Key is - begin - return This : Shortcut_Key do - This.Modifier := Mod_None; - This.Keypress := Key; - end return; - end Shortcut; - - - function "+" - (Left, Right : in Modifier_Key) - return Modifier_Key is - begin - return Left or Right; - end "+"; - - - function "+" - (Left : in Modifier_Key; - Right : in Pressable_Key) - return Shortcut_Key is - begin - return This : Shortcut_Key do - This.Modifier := Left; - This.Keypress := Right; - end return; - end "+"; - - - function "+" - (Left : in Modifier_Key; - Right : in Shortcut_Key) - return Shortcut_Key is - begin - return This : Shortcut_Key do - This.Modifier := Left or Right.Modifier; - This.Keypress := Right.Keypress; - end return; - end "+"; - - - - - function "+" - (Left, Right : in Menu_Flag) - return Menu_Flag is - begin - return Left or Right; - end "+"; - - - - - function new_fl_menu_item - (Text : in Interfaces.C.char_array; - CBack : in System.Address; - -- Data : in System.Address; - Key : in Interfaces.C.unsigned_long; - Flags : in Interfaces.C.unsigned_short) - return System.Address; - pragma Import (C, new_fl_menu_item, "new_fl_menu_item"); - - procedure free_fl_menu_item - (M : in System.Address); - pragma Import (C, free_fl_menu_item, "free_fl_menu_item"); - - - - - procedure Finalize - (This : in out Menu_Item) is - begin - Finalize (Wrapper (This)); - if This in Menu_Item then - free_fl_menu_item (This.Void_Ptr); - end if; - end Finalize; - - - - - function Create - (Text : in String; - Action : in FLTK.Callbacks.Callback; - Shortcut : in Shortcut_Key := No_Key; - Flags : in Menu_Flag := Flag_Normal) - return Menu_Item is - begin - return This : Menu_Item do - null; - end return; - end Create; - - -end FLTK.Menu_Items; - diff --git a/src/fltk_binding/fltk-menu_items.ads b/src/fltk_binding/fltk-menu_items.ads deleted file mode 100644 index 5e0751f..0000000 --- a/src/fltk_binding/fltk-menu_items.ads +++ /dev/null @@ -1,89 +0,0 @@ - - -with FLTK.Callbacks; -private with Interfaces; - - -package FLTK.Menu_Items is - - - type Menu_Item is new Wrapper with private; - - - type Shortcut_Key is private; - subtype Pressable_Key is Character range Character'Val (32) .. Character'Val (126); - function Shortcut (Key : Pressable_Key) return Shortcut_Key; - No_Key : constant Shortcut_Key; - - - type Modifier_Key is private; - function "+" (Left, Right : in Modifier_Key) return Modifier_Key; - function "+" (Left : in Modifier_Key; Right : in Pressable_Key) return Shortcut_Key; - function "+" (Left : in Modifier_Key; Right : in Shortcut_Key) return Shortcut_Key; - Mod_None : constant Modifier_Key; - Mod_Shift : constant Modifier_Key; - Mod_Ctrl : constant Modifier_Key; - Mod_Alt : constant Modifier_Key; - - - type Menu_Flag is private; - function "+" (Left, Right : in Menu_Flag) return Menu_Flag; - Flag_Normal : constant Menu_Flag; - Flag_Inactive : constant Menu_Flag; - Flag_Toggle : constant Menu_Flag; - Flag_Value : constant Menu_Flag; - Flag_Radio : constant Menu_Flag; - Flag_Invisible : constant Menu_Flag; - Flag_Submenu : constant Menu_Flag; - Flag_Divider : constant Menu_Flag; - - - function Create - (Text : in String; - Action : in FLTK.Callbacks.Callback; - Shortcut : in Shortcut_Key := No_Key; - Flags : in Menu_Flag := Flag_Normal) - return Menu_Item; - - -private - - - -- these values designed to align with FLTK enumeration types - type Modifier_Key is new Interfaces.Unsigned_8; - Mod_None : constant Modifier_Key := 2#0000#; - Mod_Shift : constant Modifier_Key := 2#0001#; - Mod_Ctrl : constant Modifier_Key := 2#0100#; - Mod_Alt : constant Modifier_Key := 2#1000#; - - - type Shortcut_Key is - record - Modifier : Modifier_Key; - Keypress : Character; - end record; - No_Key : constant Shortcut_Key := - (Modifier => Mod_None, Keypress => Character'Val (0)); - - - type Menu_Flag is new Interfaces.Unsigned_8; - Flag_Normal : constant Menu_Flag := 2#00000000#; - Flag_Inactive : constant Menu_Flag := 2#00000001#; - Flag_Toggle : constant Menu_Flag := 2#00000010#; - Flag_Value : constant Menu_Flag := 2#00000100#; - Flag_Radio : constant Menu_Flag := 2#00001000#; - Flag_Invisible : constant Menu_Flag := 2#00010000#; - -- Flag_Submenu_Pointer is currently unused - Flag_Submenu : constant Menu_Flag := 2#01000000#; - Flag_Divider : constant Menu_Flag := 2#10000000#; - - - type Menu_Item is new Wrapper with null record; - - - overriding procedure Finalize - (This : in out Menu_Item); - - -end FLTK.Menu_Items; - diff --git a/src/fltk_binding/fltk-widgets-menus.adb b/src/fltk_binding/fltk-widgets-menus.adb index d102e41..be5b7c3 100644 --- a/src/fltk_binding/fltk-widgets-menus.adb +++ b/src/fltk_binding/fltk-widgets-menus.adb @@ -3,17 +3,143 @@ with Interfaces.C; with System; use type System.Address; +use type Interfaces.C.int; +use type Interfaces.C.unsigned_long; package body FLTK.Widgets.Menus is - procedure Initialize - (This : in out Menu) is + function Shortcut + (Key : Pressable_Key) + return Shortcut_Key is begin - Initialize (Widget (This)); - This.Menu_Item_List := Menu_Vectors.Empty_Vector; - end Initialize; + return This : Shortcut_Key do + This.Modifier := Mod_None; + This.Keypress := Key; + end return; + end Shortcut; + + + + + function Key_To_C + (Key : Shortcut_Key) + return Interfaces.C.unsigned_long is + begin + return Interfaces.C.unsigned_long (Key.Modifier) * + 65536 + Character'Pos (Key.Keypress); + end Key_To_C; + + + + + function "+" + (Left, Right : in Modifier_Key) + return Modifier_Key is + begin + return Left or Right; + end "+"; + + + + + function "+" + (Left : in Modifier_Key; + Right : in Pressable_Key) + return Shortcut_Key is + begin + return This : Shortcut_Key do + This.Modifier := Left; + This.Keypress := Right; + end return; + end "+"; + + + + + function "+" + (Left : in Modifier_Key; + Right : in Shortcut_Key) + return Shortcut_Key is + begin + return This : Shortcut_Key do + This.Modifier := Left or Right.Modifier; + This.Keypress := Right.Keypress; + end return; + end "+"; + + + + + function "+" + (Left, Right : in Menu_Flag) + return Menu_Flag is + begin + return Left or Right; + end "+"; + + + + + function fl_menu_add + (M : in System.Address; + T : in Interfaces.C.char_array; + S : in Interfaces.C.unsigned_long; + C, U : in System.Address; + F : in Interfaces.C.unsigned_long) + return Interfaces.C.int; + pragma Import (C, fl_menu_add, "fl_menu_add"); + + + + + procedure Item_Hook (M, U : in System.Address); + pragma Convention (C, Item_Hook); + + procedure Item_Hook + (M, U : in System.Address) is + + Ada_Widget : access Widget'Class := + Widget_Convert.To_Pointer (fl_widget_get_user_data (M)); + + Action : access Widget_Callback'Class := + Callback_Convert.To_Pointer (U); + + begin + Action.Call (Ada_Widget.all); + end Item_Hook; + + + + + procedure Add + (This : in out Menu; + Text : in String; + Action : access Widget_Callback'Class := null; + Shortcut : in Shortcut_Key := No_Key; + Flags : in Menu_Flag := Flag_Normal) is + + Place : Interfaces.C.int; + Callback, User_Data : System.Address; + + begin + if Action = null then + Callback := System.Null_Address; + User_Data := System.Null_Address; + else + Callback := Item_Hook'Address; + User_Data := Callback_Convert.To_Address (Action); + end if; + + Place := fl_menu_add + (This.Void_Ptr, + Interfaces.C.To_C (Text), + Key_To_C (Shortcut), + Callback, + User_Data, + Interfaces.C.unsigned_long (Flags)); + end Add; end FLTK.Widgets.Menus; diff --git a/src/fltk_binding/fltk-widgets-menus.ads b/src/fltk_binding/fltk-widgets-menus.ads index 7a08de4..acb59bd 100644 --- a/src/fltk_binding/fltk-widgets-menus.ads +++ b/src/fltk_binding/fltk-widgets-menus.ads @@ -1,37 +1,103 @@ -private with Ada.Containers.Vectors; -private with FLTK.Menu_Items; +private with Interfaces; +private with System; package FLTK.Widgets.Menus is type Menu is abstract new Widget with private; + type Menu_Cursor (Data : access Menu'Class) is limited null record + with Implicit_Dereference => Data; + + + type Menu_Item is private; + type Menu_Item_Cursor (Data : access Menu_Item) is limited null record + with Implicit_Dereference => Data; + + type Index is new Positive; + type Shortcut_Key is private; + subtype Pressable_Key is Character range Character'Val (32) .. Character'Val (126); + function Shortcut (Key : Pressable_Key) return Shortcut_Key; + No_Key : constant Shortcut_Key; + + + type Modifier_Key is private; + function "+" (Left, Right : in Modifier_Key) return Modifier_Key; + function "+" (Left : in Modifier_Key; Right : in Pressable_Key) return Shortcut_Key; + function "+" (Left : in Modifier_Key; Right : in Shortcut_Key) return Shortcut_Key; + Mod_None : constant Modifier_Key; + Mod_Shift : constant Modifier_Key; + Mod_Ctrl : constant Modifier_Key; + Mod_Alt : constant Modifier_Key; + + + type Menu_Flag is private; + function "+" (Left, Right : in Menu_Flag) return Menu_Flag; + Flag_Normal : constant Menu_Flag; + Flag_Inactive : constant Menu_Flag; + Flag_Toggle : constant Menu_Flag; + Flag_Value : constant Menu_Flag; + Flag_Radio : constant Menu_Flag; + Flag_Invisible : constant Menu_Flag; + Flag_Submenu : constant Menu_Flag; + Flag_Divider : constant Menu_Flag; + + function Create (X, Y, W, H : in Integer; Text : in String) return Menu is abstract; + procedure Add + (This : in out Menu; + Text : in String; + Action : access Widget_Callback'Class := null; + Shortcut : in Shortcut_Key := No_Key; + Flags : in Menu_Flag := Flag_Normal); + + private - type Menu_Item_Access is access all FLTK.Menu_Items.Menu_Item; - package Menu_Vectors is new Ada.Containers.Vectors (Index, Menu_Item_Access); + type Menu is abstract new Widget with null record; - type Menu is abstract new Widget with - record - Menu_Item_List : Menu_Vectors.Vector; - end record; + type Menu_Item is new System.Address; - overriding procedure Initialize - (This : in out Menu); + -- these values designed to align with FLTK enumeration types + type Modifier_Key is new Interfaces.Unsigned_8; + Mod_None : constant Modifier_Key := 2#00000000#; + Mod_Shift : constant Modifier_Key := 2#00000001#; + Mod_Ctrl : constant Modifier_Key := 2#00000100#; + Mod_Alt : constant Modifier_Key := 2#00001000#; + + + type Shortcut_Key is + record + Modifier : Modifier_Key; + Keypress : Character; + end record; + No_Key : constant Shortcut_Key := + (Modifier => Mod_None, Keypress => Character'Val (0)); + + + type Menu_Flag is new Interfaces.Unsigned_8; + Flag_Normal : constant Menu_Flag := 2#00000000#; + Flag_Inactive : constant Menu_Flag := 2#00000001#; + Flag_Toggle : constant Menu_Flag := 2#00000010#; + Flag_Value : constant Menu_Flag := 2#00000100#; + Flag_Radio : constant Menu_Flag := 2#00001000#; + Flag_Invisible : constant Menu_Flag := 2#00010000#; + -- Flag_Submenu_Pointer unlikely to be used + Flag_Submenu : constant Menu_Flag := 2#01000000#; + Flag_Divider : constant Menu_Flag := 2#10000000#; end FLTK.Widgets.Menus; diff --git a/src/fltk_binding/fltk-widgets.ads b/src/fltk_binding/fltk-widgets.ads index 1c21ca4..0a123bf 100644 --- a/src/fltk_binding/fltk-widgets.ads +++ b/src/fltk_binding/fltk-widgets.ads @@ -106,6 +106,7 @@ private package Widget_Convert is new System.Address_To_Access_Conversions (Widget'Class); + package Callback_Convert is new System.Address_To_Access_Conversions (Widget_Callback'Class); function fl_widget_get_user_data -- cgit