From bf5b67dee0d61996c3937dd8b255d5fcf2198973 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Fri, 11 Nov 2016 10:53:05 +1100 Subject: Simplified widget callbacks --- src/adapad.adb | 113 ++++++++++++++--------------- src/adapad.ads | 121 -------------------------------- src/fltk_binding/fltk-widgets-menus.adb | 13 ++-- src/fltk_binding/fltk-widgets-menus.ads | 2 +- src/fltk_binding/fltk-widgets.adb | 10 +-- src/fltk_binding/fltk-widgets.ads | 17 +++-- src/windows-find.adb | 9 +-- src/windows-find.ads | 6 -- src/windows-replace.adb | 9 +-- src/windows-replace.ads | 6 -- src/windows.adb | 7 +- src/windows.ads | 11 +-- 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; -- cgit