Menu callbacks working, also some quick testing code that'll probably get deleted later because wynaut

1 files changed, 131 insertions, 5 deletions

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;