From 7a84d0f3d0d181196b24795592a260e05b63fa74 Mon Sep 17 00:00:00 2001
From: Jed Barber <jjbarber@y7mail.com>
Date: Tue, 4 Oct 2016 00:32:30 +1100
Subject: Find/Replace marshalling back to Adapad Main done, some
Group/Widget_Cursor stuff removed
---
src/adapad.adb | 43 ++++++++++++++++
src/editor_windows.adb | 87 +++++++++++++++++++++++++-------
src/editor_windows.ads | 42 ++++++++++++---
src/fltk_binding/fltk-widgets-groups.adb | 4 +-
src/fltk_binding/fltk-widgets-groups.ads | 2 +-
src/fltk_binding/fltk-widgets.adb | 4 +-
src/fltk_binding/fltk-widgets.ads | 9 +---
7 files changed, 151 insertions(+), 40 deletions(-)
(limited to 'src')
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
--
cgit