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/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 + 11 files changed, 214 insertions(+), 281 deletions(-) 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/fltk_binding') 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