Simplified widget callbacks

12 files changed, 90 insertions, 234 deletions

diff --git a/src/adapad.adb b/src/adapad.adb
index 5d53d7c..3868877 100644
--- a/src/adapad.adb
+++ b/src/adapad.adb
@@ -16,6 +16,19 @@ with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
 package body Adapad is
 
 
+    --  forward declarations of helper functions
+
+    procedure Set_Title;
+    function Safe_To_Discard return Boolean;
+    procedure Do_Save;
+    procedure Do_Save_As;
+    procedure Load_File (Name : in String);
+    procedure Save_File (Name : in String);
+    procedure Centre (Win : in out FLTK.Widgets.Groups.Windows.Window'Class);
+
+
+
+
     --  global state of the text editor
 
     Editor   : Windows.Editor.Editor_Window   := Windows.Editor.Create (800, 500);
@@ -53,9 +66,8 @@ package body Adapad is
 
     --  callbacks for the menu
 
-    overriding procedure Call
-           (This : in     New_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure New_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         if not Safe_To_Discard then return; end if;
         Filename := To_Unbounded_String (0);
@@ -63,14 +75,13 @@ package body Adapad is
         Buffer.Remove_Selected_Text;
         Changed := False;
         Buffer.Call_Modify_Callbacks;
-    end Call;
+    end New_CB;
 
 
 
 
-    overriding procedure Call
-           (This : in     Open_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure Open_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         if not Safe_To_Discard then return; end if;
         declare
@@ -81,131 +92,119 @@ package body Adapad is
                 Load_File (New_Filename);
             end if;
         end;
-    end Call;
+    end Open_CB;
 
 
 
 
-    overriding procedure Call
-           (This : in     Save_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure Save_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         Do_Save;
-    end Call;
+    end Save_CB;
 
 
 
 
-    overriding procedure Call
-           (This : in     Save_As_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure Save_As_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         Do_Save_As;
-    end Call;
+    end Save_As_CB;
 
 
 
 
-    overriding procedure Call
-           (This : in     Quit_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure Quit_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         if not Safe_To_Discard then return; end if;
         Hide;
-    end Call;
+    end Quit_CB;
 
 
 
 
-    overriding procedure Call
-           (This : in     Undo_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure Undo_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         Editor.Undo;
-    end Call;
+    end Undo_CB;
 
 
 
 
-    overriding procedure Call
-           (This : in     Cut_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure Cut_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         Editor.Cut;
-    end Call;
+    end Cut_CB;
 
 
 
 
-    overriding procedure Call
-           (This : in     Copy_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure Copy_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         Editor.Copy;
-    end Call;
+    end Copy_CB;
 
 
 
 
-    overriding procedure Call
-           (This : in     Paste_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure Paste_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         Editor.Paste;
-    end Call;
+    end Paste_CB;
 
 
 
 
-    overriding procedure Call
-           (This : in     Delete_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure Delete_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         Editor.Delete;
-    end Call;
+    end Delete_CB;
 
 
 
 
-    overriding procedure Call
-           (This : in     Select_All_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure Select_All_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         Buffer.Set_Selection (0, Buffer.Length);
-    end Call;
+    end Select_All_CB;
 
 
 
 
-    overriding procedure Call
-           (This : in     Find_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure Find_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         Centre (Find);
         Find.Show;
-    end Call;
+    end Find_CB;
 
 
 
 
-    overriding procedure Call
-           (This : in     Replace_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure Replace_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         Centre (Replace);
         Replace.Show;
-    end Call;
+    end Replace_CB;
 
 
 
 
-    overriding procedure Call
-           (This : in     About_Callback;
-            Item : in out FLTK.Widgets.Widget'Class) is
+    procedure About_CB
+           (Item : in out FLTK.Widgets.Widget'Class) is
     begin
         Centre (About);
         About.Show;
-    end Call;
+    end About_CB;
 
 
 
@@ -396,6 +395,8 @@ package body Adapad is
     end Centre;
 
 
+
+
 begin
 
 
diff --git a/src/adapad.ads b/src/adapad.ads
index 45cd6ad..0695315 100644
--- a/src/adapad.ads
+++ b/src/adapad.ads
@@ -1,12 +1,5 @@
 
 
-private with FLTK.Widgets;
-private with FLTK.Widgets.Groups.Windows;
-private with FLTK.Text_Buffers;
-private with Windows.Find;
-private with Windows.Replace;
-
-
 package Adapad is
 
 
@@ -14,119 +7,5 @@ package Adapad is
     procedure Hide;
 
 
-private
-
-
-    --  helper functions
-
-    procedure Set_Title;
-    function Safe_To_Discard return Boolean;
-    procedure Do_Save;
-    procedure Do_Save_As;
-    procedure Load_File (Name : in String);
-    procedure Save_File (Name : in String);
-    procedure Centre (Win : in out FLTK.Widgets.Groups.Windows.Window'Class);
-
-
-    --  callbacks
-
-    type New_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     New_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    New_CB : aliased New_Callback;
-
-
-    type Open_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Open_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    Open_CB : aliased Open_Callback;
-
-
-    type Save_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Save_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    Save_CB : aliased Save_Callback;
-
-
-    type Save_As_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Save_As_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    Save_As_CB : aliased Save_As_Callback;
-
-
-    type Quit_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Quit_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    Quit_CB : aliased Quit_Callback;
-
-
-    type Undo_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Undo_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    Undo_CB : aliased Undo_Callback;
-
-
-    type Cut_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Cut_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    Cut_CB : aliased Cut_Callback;
-
-
-    type Copy_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Copy_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    Copy_CB : aliased Copy_Callback;
-
-
-    type Paste_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Paste_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    Paste_CB : aliased Paste_Callback;
-
-
-    type Delete_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Delete_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    Delete_CB : aliased Delete_Callback;
-
-
-    type Select_All_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Select_All_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    Select_All_CB : aliased Select_All_Callback;
-
-
-    type Find_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Find_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    Find_CB : aliased Find_Callback;
-
-
-    type Replace_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Replace_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    Replace_CB : aliased Replace_Callback;
-
-
-    type About_Callback is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     About_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-    About_CB : aliased About_Callback;
-
-
 end Adapad;
 
diff --git a/src/fltk_binding/fltk-widgets-menus.adb b/src/fltk_binding/fltk-widgets-menus.adb
index 7669820..0f50fc8 100644
--- a/src/fltk_binding/fltk-widgets-menus.adb
+++ b/src/fltk_binding/fltk-widgets-menus.adb
@@ -98,16 +98,13 @@ package body FLTK.Widgets.Menus is
     pragma Convention (C, Item_Hook);
 
     procedure Item_Hook
-           (M, U : in System.Address) is
-
+           (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);
-
+        Action : Widget_Callback := Callback_Convert.To_Pointer (U);
     begin
-        Action.Call (Ada_Widget.all);
+        Action.all (Ada_Widget.all);
     end Item_Hook;
 
 
@@ -116,7 +113,7 @@ package body FLTK.Widgets.Menus is
     procedure Add
            (This     : in out Menu;
             Text     : in     String;
-            Action   : access Widget_Callback'Class := null;
+            Action   : in     Widget_Callback := null;
             Shortcut : in     Shortcut_Key := No_Key;
             Flags    : in     Menu_Flag := Flag_Normal)
     is
diff --git a/src/fltk_binding/fltk-widgets-menus.ads b/src/fltk_binding/fltk-widgets-menus.ads
index acb59bd..27b9d4a 100644
--- a/src/fltk_binding/fltk-widgets-menus.ads
+++ b/src/fltk_binding/fltk-widgets-menus.ads
@@ -57,7 +57,7 @@ package FLTK.Widgets.Menus is
     procedure Add
            (This     : in out Menu;
             Text     : in     String;
-            Action   : access Widget_Callback'Class := null;
+            Action   : in     Widget_Callback := null;
             Shortcut : in     Shortcut_Key := No_Key;
             Flags    : in     Menu_Flag := Flag_Normal);
 
diff --git a/src/fltk_binding/fltk-widgets.adb b/src/fltk_binding/fltk-widgets.adb
index 256b8e6..9ec2350 100644
--- a/src/fltk_binding/fltk-widgets.adb
+++ b/src/fltk_binding/fltk-widgets.adb
@@ -242,7 +242,7 @@ package body FLTK.Widgets is
         Ada_Widget : access Widget'Class :=
             Widget_Convert.To_Pointer (U);
     begin
-        Ada_Widget.Callback.Call (Ada_Widget.all);
+        Ada_Widget.Callback.all (Ada_Widget.all);
     end Callback_Hook;
 
 
@@ -250,10 +250,12 @@ package body FLTK.Widgets is
 
     procedure Set_Callback
            (This : in out Widget;
-            Func : not null access Widget_Callback'Class) is
+            Func : in     Widget_Callback) is
     begin
-        This.Callback := Func;
-        fl_widget_set_callback (This.Void_Ptr, Callback_Hook'Address);
+        if Func /= null then
+            This.Callback := Func;
+            fl_widget_set_callback (This.Void_Ptr, Callback_Hook'Address);
+        end if;
     end Set_Callback;
 
 
diff --git a/src/fltk_binding/fltk-widgets.ads b/src/fltk_binding/fltk-widgets.ads
index 7af5e2b..d1c4b89 100644
--- a/src/fltk_binding/fltk-widgets.ads
+++ b/src/fltk_binding/fltk-widgets.ads
@@ -5,6 +5,7 @@ with FLTK.Images;
 limited with FLTK.Widgets.Groups;
 private with System;
 private with System.Address_To_Access_Conversions;
+private with Ada.Unchecked_Conversion;
 
 
 package FLTK.Widgets is
@@ -13,10 +14,8 @@ package FLTK.Widgets is
     type Widget is abstract new Wrapper with private;
 
 
-    type Widget_Callback is interface;
-    procedure Call
-           (This : in     Widget_Callback;
-            Item : in out Widget'Class) is abstract;
+    type Widget_Callback is access procedure
+           (Item : in out Widget'Class);
 
 
     type Font_Size is new Natural;
@@ -87,7 +86,7 @@ package FLTK.Widgets is
 
     procedure Set_Callback
            (This : in out Widget;
-            Func : not null access Widget_Callback'Class);
+            Func : in     Widget_Callback);
 
 
     function Get_X
@@ -135,13 +134,17 @@ private
 
     type Widget is abstract new Wrapper with
         record
-            Callback      : access Widget_Callback'Class;
+            Callback      : Widget_Callback;
             Current_Image : access FLTK.Images.Image'Class;
         end record;
 
 
     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);
+    --  package Callback_Convert is new System.Address_To_Access_Conversions (Widget_Callback);
+    package Callback_Convert is
+        function To_Pointer is new Ada.Unchecked_Conversion (System.Address, Widget_Callback);
+        function To_Address is new Ada.Unchecked_Conversion (Widget_Callback, System.Address);
+    end Callback_Convert;
 
 
     function fl_widget_get_user_data
diff --git a/src/windows-find.adb b/src/windows-find.adb
index 5459e38..f061ba3 100644
--- a/src/windows-find.adb
+++ b/src/windows-find.adb
@@ -21,11 +21,8 @@ package body Windows.Find is
 
 
 
-    Find_M : aliased Find_Marshaller;
-
-    overriding procedure Call
-           (This : in     Find_Marshaller;
-            Item : in out W.Widget'Class)
+    procedure Find_M
+           (Item : in out W.Widget'Class)
     is
         use type BU.State;
         type Find_Window_Access is access all Find_Window;
@@ -36,7 +33,7 @@ package body Windows.Find is
                    (Dialog.Find_What.Get_Value,
                     Dialog.Match_Case.Get_State = BU.On);
         end if;
-    end Call;
+    end Find_M;
 
 
 
diff --git a/src/windows-find.ads b/src/windows-find.ads
index 31ea2f6..3708d0d 100644
--- a/src/windows-find.ads
+++ b/src/windows-find.ads
@@ -42,12 +42,6 @@ package Windows.Find is
 private
 
 
-    type Find_Marshaller is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Find_Marshaller;
-            Item : in out FLTK.Widgets.Widget'Class);
-
-
     type Find_Window is new FLTK.Widgets.Groups.Windows.Double.Double_Window with
         record
             Find_What  : FLTK.Widgets.Inputs.Input;
diff --git a/src/windows-replace.adb b/src/windows-replace.adb
index a0bdcff..f158f7b 100644
--- a/src/windows-replace.adb
+++ b/src/windows-replace.adb
@@ -21,11 +21,8 @@ package body Windows.Replace is
 
 
 
-    Replace_M : aliased Replace_Marshaller;
-
-    overriding procedure Call
-           (This : in     Replace_Marshaller;
-            Item : in out W.Widget'Class)
+    procedure Replace_M
+           (Item : in out W.Widget'Class)
     is
         use type BU.State;
         type Replace_Window_Access is access all Replace_Window;
@@ -38,7 +35,7 @@ package body Windows.Replace is
                     Dialog.Match_Case.Get_State = BU.On,
                     Dialog.Replace_All.Get_State = BU.On);
         end if;
-    end Call;
+    end Replace_M;
 
 
 
diff --git a/src/windows-replace.ads b/src/windows-replace.ads
index 854a882..1525859 100644
--- a/src/windows-replace.ads
+++ b/src/windows-replace.ads
@@ -42,12 +42,6 @@ package Windows.Replace is
 private
 
 
-    type Replace_Marshaller is new FLTK.Widgets.Widget_Callback with null record;
-    overriding procedure Call
-           (This : in     Replace_Marshaller;
-            Item : in out FLTK.Widgets.Widget'Class);
-
-
     type Replace_Window is new FLTK.Widgets.Groups.Windows.Double.Double_Window with
         record
             Find_What, Replace_With : FLTK.Widgets.Inputs.Input;
diff --git a/src/windows.adb b/src/windows.adb
index 646ffb4..bf070a4 100644
--- a/src/windows.adb
+++ b/src/windows.adb
@@ -18,9 +18,8 @@ package body Windows is
     --  used to hide about/find/replace/etc windows instead
     --  of constantly creating and destroying them
 
-    overriding procedure Call
-           (This : in     Hide_Callback;
-            Item : in out W.Widget'Class)
+    procedure Hide_CB
+           (Item : in out W.Widget'Class)
     is
         P : access G.Group'Class;
     begin
@@ -37,7 +36,7 @@ package body Windows is
             end loop;
             WN.Window (P.all).Hide;
         end if;
-    end Call;
+    end Hide_CB;
 
 
 end Windows;
diff --git a/src/windows.ads b/src/windows.ads
index 3144bba..b187b7b 100644
--- a/src/windows.ads
+++ b/src/windows.ads
@@ -13,15 +13,8 @@ package Windows is
 private
 
 
-    type Hide_Callback is new FLTK.Widgets.Widget_Callback with null record;
-
-
-    overriding procedure Call
-           (This : in     Hide_Callback;
-            Item : in out FLTK.Widgets.Widget'Class);
-
-
-    Hide_CB : aliased Hide_Callback;
+    procedure Hide_CB
+           (Item : in out FLTK.Widgets.Widget'Class);
 
 
 end Windows;