summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJed Barber <jjbarber@y7mail.com>2016-11-11 10:53:05 +1100
committerJed Barber <jjbarber@y7mail.com>2016-11-11 10:53:05 +1100
commitbf5b67dee0d61996c3937dd8b255d5fcf2198973 (patch)
tree0a53efae21ee2abba5b1f24fb0488dd022477286 /src
parent646bb5b98226ecfcee8b02d669b9cef5d00bbded (diff)
Simplified widget callbacks
Diffstat (limited to 'src')
-rw-r--r--src/adapad.adb113
-rw-r--r--src/adapad.ads121
-rw-r--r--src/fltk_binding/fltk-widgets-menus.adb13
-rw-r--r--src/fltk_binding/fltk-widgets-menus.ads2
-rw-r--r--src/fltk_binding/fltk-widgets.adb10
-rw-r--r--src/fltk_binding/fltk-widgets.ads17
-rw-r--r--src/windows-find.adb9
-rw-r--r--src/windows-find.ads6
-rw-r--r--src/windows-replace.adb9
-rw-r--r--src/windows-replace.ads6
-rw-r--r--src/windows.adb7
-rw-r--r--src/windows.ads11
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;