diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/adapad.adb | 43 | ||||
| -rw-r--r-- | src/editor_windows.adb | 87 | ||||
| -rw-r--r-- | src/editor_windows.ads | 42 | ||||
| -rw-r--r-- | src/fltk_binding/fltk-widgets-groups.adb | 4 | ||||
| -rw-r--r-- | src/fltk_binding/fltk-widgets-groups.ads | 2 | ||||
| -rw-r--r-- | src/fltk_binding/fltk-widgets.adb | 4 | ||||
| -rw-r--r-- | src/fltk_binding/fltk-widgets.ads | 9 |
7 files changed, 151 insertions, 40 deletions
diff --git a/src/adapad.adb b/src/adapad.adb index 7ba743e..7440ce9 100644 --- a/src/adapad.adb +++ b/src/adapad.adb @@ -16,6 +16,8 @@ use FLTK.Widgets.Groups.Windows; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Text_IO; + function Adapad return Integer is @@ -271,6 +273,45 @@ function Adapad return Integer is + -- callbacks for the find/replace windows + + type Do_Find_Callback is new Editor_Windows.Find_Callback with null record; + Do_Find_CB : aliased Do_Find_Callback; + + overriding procedure Call + (This : in Do_Find_Callback; + Item : in String; + Match_Case : in Boolean) is + begin + Ada.Text_IO.Put_Line ("Finding " & Item); + if Match_Case then + Ada.Text_IO.Put_Line ("Matching case"); + end if; + end Call; + + + + + type Do_Replace_Callback is new Editor_Windows.Replace_Callback with null record; + Do_Replace_CB : aliased Do_Replace_Callback; + + overriding procedure Call + (This : in Do_Replace_Callback; + Item, Replace_With : in String; + Match_Case, Replace_All : in Boolean) is + begin + Ada.Text_IO.Put_Line ("Replacing " & Item & " with " & Replace_With); + if Match_Case then + Ada.Text_IO.Put_Line ("Matching case"); + end if; + if Replace_All then + Ada.Text_IO.Put_Line ("Replacing all"); + end if; + end Call; + + + + -- helper functions procedure Set_Title is @@ -404,6 +445,8 @@ begin end; + Find.Set_Find_Callback (Do_Find_CB'Access); + Replace.Set_Replace_Callback (Do_Replace_CB'Access); Buffer.Add_Modify_Callback (Mod_CB'Access); Editor.Set_Callback (Quit_CB'Access); Editor.Set_Buffer (Buffer); diff --git a/src/editor_windows.adb b/src/editor_windows.adb index f4a1151..dffad97 100644 --- a/src/editor_windows.adb +++ b/src/editor_windows.adb @@ -4,6 +4,8 @@ with FLTK.Enums; use FLTK.Enums; with FLTK.Widgets; use FLTK.Widgets; +with FLTK.Widgets.Groups; +use FLTK.Widgets.Groups; with FLTK.Widgets.Groups.Windows; use FLTK.Widgets.Groups.Windows; @@ -144,19 +146,22 @@ package body Editor_Windows is overriding procedure Call (This : in Hide_Callback; Item : in out Widget'Class) is + + P : access Group'Class; + begin - -- - -- this is an ugly hack - -- - -- it only works because the Item will either be the About/Find/Replace window - -- directly or it'll be a close/cancel button in said window - -- - -- need to figure out how to properly loop up via Widget Parent method - -- if Item in Window'Class then Window (Item).Hide; else - Window (Item.Parent.Data.all).Hide; + P := Item.Parent; + loop + if P = null then + return; + end if; + exit when P.all in Window'Class; + P := P.Parent; + end loop; + Window (P.all).Hide; end if; end Call; @@ -233,6 +238,24 @@ package body Editor_Windows is -- Find_Window functions and procedures + Find_M : aliased Find_Marshaller; + + overriding procedure Call + (This : in Find_Marshaller; + Item : in out Widget'Class) is + + type Find_Window_Access is access all Find_Window; + The_Window : access Find_Window := Find_Window_Access (Item.Parent); + + begin + if The_Window.Callback /= null then + The_Window.Callback.Call ("Hello", True); + end if; + end Call; + + + + function Create return Find_Window is My_Width : Integer := 350; My_Height : Integer := 130; @@ -267,13 +290,17 @@ package body Editor_Windows is Button_Line, Button_Width, Button_Height, "Cancel")), Start => Enter_Button'(Create ((My_Width - 2 * Button_Width) * 2 / 3 + Button_Width, - Button_Line, Button_Width, Button_Height, "Find"))) do + Button_Line, Button_Width, Button_Height, "Find")), + + Callback => null) do This.Add (This.Find_What); This.Add (This.Match_Case); This.Add (This.Cancel); This.Cancel.Set_Callback (Hide_CB'Access); This.Add (This.Start); + This.Start.Set_Callback (Find_M'Access); + This.Set_Callback (Hide_CB'Access); end return; end Create; @@ -302,18 +329,36 @@ package body Editor_Windows is - procedure Set_Function + procedure Set_Find_Callback (This : in out Find_Window; - Func : access procedure (Item : in String)) is + Func : not null access Find_Callback'Class) is begin - null; - end Set_Function; + This.Callback := Func; + end Set_Find_Callback; -- Replace_Window functions and procedures + Replace_M : aliased Replace_Marshaller; + + overriding procedure Call + (This : in Replace_Marshaller; + Item : in out Widget'Class) is + + type Replace_Window_Access is access all Replace_Window; + The_Window : access Replace_Window := Replace_Window_Access (Item.Parent); + + begin + if The_Window.Callback /= null then + The_Window.Callback.Call ("Hello", "There", True, True); + end if; + end Call; + + + + function Create return Replace_Window is My_Width : Integer := 350; My_Height : Integer := 180; @@ -357,7 +402,9 @@ package body Editor_Windows is Button_Line, Button_Width, Button_Height, "Cancel")), Start => Enter_Button'(Create ((My_Width - 2 * Button_Width) * 2 / 3 + Button_Width, - Button_Line, Button_Width, Button_Height, "Replace"))) do + Button_Line, Button_Width, Button_Height, "Replace")), + + Callback => null) do This.Add (This.Find_What); This.Add (This.Replace_With); @@ -366,6 +413,8 @@ package body Editor_Windows is This.Add (This.Cancel); This.Cancel.Set_Callback (Hide_CB'Access); This.Add (This.Start); + This.Start.Set_Callback (Replace_M'Access); + This.Set_Callback (Hide_CB'Access); end return; end Create; @@ -394,12 +443,12 @@ package body Editor_Windows is - procedure Set_Function + procedure Set_Replace_Callback (This : in out Replace_Window; - Func : access procedure (Item : in String)) is + Func : not null access Replace_Callback'Class) is begin - null; - end Set_Function; + This.Callback := Func; + end Set_Replace_Callback; end Editor_Windows; diff --git a/src/editor_windows.ads b/src/editor_windows.ads index 6fede6d..3acec25 100644 --- a/src/editor_windows.ads +++ b/src/editor_windows.ads @@ -83,6 +83,13 @@ package Editor_Windows is type Find_Window is new Double_Window with private; + type Find_Callback is interface; + procedure Call + (This : in Find_Callback; + Item : in String; + Match_Case : in Boolean) is abstract; + + function Create return Find_Window; @@ -97,9 +104,9 @@ package Editor_Windows is return Find_Window; - procedure Set_Function + procedure Set_Find_Callback (This : in out Find_Window; - Func : access procedure (Item : in String)); + Func : not null access Find_Callback'Class); @@ -107,6 +114,13 @@ package Editor_Windows is type Replace_Window is new Double_Window with private; + type Replace_Callback is interface; + procedure Call + (This : in Replace_Callback; + Item, Replace_With : in String; + Match_Case, Rep_All : in Boolean) is abstract; + + function Create return Replace_Window; @@ -121,9 +135,9 @@ package Editor_Windows is return Replace_Window; - procedure Set_Function + procedure Set_Replace_Callback (This : in out Replace_Window; - Func : access procedure (Item : in String)); + Func : not null access Replace_Callback'Class); private @@ -161,23 +175,35 @@ private end record; + type Find_Marshaller is new Widget_Callback with null record; + overriding procedure Call + (This : in Find_Marshaller; + Item : in out Widget'Class); + + type Find_Window is new Double_Window with record Find_What : Input; Match_Case : Check_Button; Cancel : Button; Start : Enter_Button; - -- callback + Callback : access Find_Callback'Class; end record; + type Replace_Marshaller is new Widget_Callback with null record; + overriding procedure Call + (This : in Replace_Marshaller; + Item : in out Widget'Class); + + type Replace_Window is new Double_Window with record Find_What, Replace_With : Input; Match_Case, Replace_All : Check_Button; - Cancel : Button; - Start : Enter_Button; - -- callback + Cancel : Button; + Start : Enter_Button; + Callback : access Replace_Callback'Class; end record; diff --git a/src/fltk_binding/fltk-widgets-groups.adb b/src/fltk_binding/fltk-widgets-groups.adb index 3ffd1e3..2197d28 100644 --- a/src/fltk_binding/fltk-widgets-groups.adb +++ b/src/fltk_binding/fltk-widgets-groups.adb @@ -109,7 +109,7 @@ package body FLTK.Widgets.Groups is function Child (This : in Group; Place : in Index) - return Widget_Cursor is + return access Widget'Class is Widget_Ptr : System.Address := fl_group_child (This.Void_Ptr, Interfaces.C.int (Place - 1)); @@ -118,7 +118,7 @@ package body FLTK.Widgets.Groups is Widget_Convert.To_Pointer (fl_widget_get_user_data (Widget_Ptr)); begin - return Ref : Widget_Cursor (Data => Actual_Widget); + return Actual_Widget; end Child; diff --git a/src/fltk_binding/fltk-widgets-groups.ads b/src/fltk_binding/fltk-widgets-groups.ads index e777f04..57faf87 100644 --- a/src/fltk_binding/fltk-widgets-groups.ads +++ b/src/fltk_binding/fltk-widgets-groups.ads @@ -24,7 +24,7 @@ package FLTK.Widgets.Groups is function Child (This : in Group; Place : in Index) - return Widget_Cursor; + return access Widget'Class; function Number_Of_Children diff --git a/src/fltk_binding/fltk-widgets.adb b/src/fltk_binding/fltk-widgets.adb index 5ec090d..0a159c7 100644 --- a/src/fltk_binding/fltk-widgets.adb +++ b/src/fltk_binding/fltk-widgets.adb @@ -110,7 +110,7 @@ package body FLTK.Widgets is function Parent (This : in Widget) - return Group_Cursor is + return access FLTK.Widgets.Groups.Group'Class is Parent_Ptr : System.Address; Actual_Parent : access Group'Class; @@ -120,7 +120,7 @@ package body FLTK.Widgets is if Parent_Ptr /= System.Null_Address then Actual_Parent := Group_Convert.To_Pointer (fl_widget_get_user_data (Parent_Ptr)); end if; - return Ref : Group_Cursor (Data => Actual_Parent); + return Actual_Parent; end Parent; diff --git a/src/fltk_binding/fltk-widgets.ads b/src/fltk_binding/fltk-widgets.ads index c0f89c1..05bba29 100644 --- a/src/fltk_binding/fltk-widgets.ads +++ b/src/fltk_binding/fltk-widgets.ads @@ -10,8 +10,6 @@ package FLTK.Widgets is type Widget is abstract new Wrapper with private; - type Widget_Cursor (Data : access Widget'Class) is limited null record - with Implicit_Dereference => Data; type Widget_Callback is interface; @@ -20,11 +18,6 @@ package FLTK.Widgets is Item : in out Widget'Class) is abstract; - -- would like to move this definition to FLTK.Widgets.Groups somehow - type Group_Cursor (Data : access FLTK.Widgets.Groups.Group'Class) is limited null record - with Implicit_Dereference => Data; - - type Font_Size is new Natural; Normal_Size : constant Font_Size := 14; type Color is new Natural; @@ -38,7 +31,7 @@ package FLTK.Widgets is function Parent (This : in Widget) - return Group_Cursor; + return access FLTK.Widgets.Groups.Group'Class; function Get_Box |