In my first article, I explained that there were two ways to implement
the Font_Dialog type, using either one observer for all the widgets or
separate observers for each widget.
I implemented the example then using the latter technique. In this
article I now use the former technique, and implement the dialog itself
as an observer. Each widget component binds to the same observer, and
they all call the same Update operation to signal state changes.
Implementation
In order to determine which widget signalled the state change, we must
also include the widget as an argument of the Update operation:
package Widgets
...
procedure Update
(Observer : access Widget_Observer;
Widget : access Widget_Type'Class);
As an example, when the user clicks the mouse to "push" a button, the
button signals its observer, passing itself as the argument:
package body Widgets.Buttons is
procedure Handle_Mouse
(Widget : in out Button_Widget;
Event : in Mouse_Event_Type) is
begin
Update (Widget.Observer, Widget'Access); <--
end;
Note that we are only allowed to take the 'Access of an object that has
an "aliased view." This is true for the Widget parameter above because
tagged parameters are implicitly aliased.
We now implement the Font_Dialog type as a private derivation from
Widget_Observer, and bind each widget to the dialog:
type Font_Dialog is
new Widget_Observer with record
OK : aliased Button_Widget (Font_Dialog'Access);
Cancel : aliased Button_Widget (Font_Dialog'Access);
Font_List : aliased List_Box_Widget (Font_Dialog'Access);
Font_Name : aliased Entry_Field_Widget (Font_Dialog'Access);
end record;
procedure Update
(Dialog : access Font_Dialog;
Widget : access Widget_Type'Class);
Since all the widgets are bound to the same dialog, they all call the
same Update operation. The widget parameter is there to identify the
widget that signalled its dialog observer.
The dialog implements Update by comparing the widget parameter to each
of its widget components. When it finds a match, it performs update
processing specific to that widget.
We want to compare widget references, not widget values. Not only is
this more efficient, but it's conceivable that you could have different
components with the same value, which would yield a false positive
during the comparison.
There's no predefined equality operator defined for access parameters,
so we must explicitly convert the widget parameter to a named access
type:
procedure Update
(Dialog : access Font_Dialog;
Widget : access Widget_Type'Class) is
type Widget_Access is access constant Widget_Type'Class;
for Widget_Access'Storage_Size use 0;
WA : constant Widget_Access := Widget_Access (Widget);
begin
if WA = Dialog.OK'Access then
Do_Update_OK_Button (Dialog);
elsif WA = Dialog.Cancel'Access then
Do_Update_Cancel_Button (Dialog);
elsif WA = Dialog.Font_List'Access then
Do_Update_Font_List (Dialog);
elsif WA = Dialog.Font_Name'Access then
null;
else
raise Program_Error;
end if;
end Update;
We simply compare the widget access object (which has an named type) to
the access value of each dialog component. Note again that in order to
take the 'Access of an object, we need to have an aliased view. That is
why all the widget components in the dialog record were declared as
aliased.
The following code is ready for GNAT Chop:
--STX
with Ada.Text_IO; use Ada.Text_IO;
package body Font_Dialogs is
procedure Show (Dialog : in out Font_Dialog) is
begin
null;
end;
procedure Hide (Dialog : in out Font_Dialog) is
begin
null;
end;
procedure Push_OK_Button (Dialog : in out Font_Dialog) is
begin
Handle_Mouse (Dialog.OK, Event => Mouse_Event_Type'First);
end;
procedure Push_Cancel_Button (Dialog : in out Font_Dialog) is
begin
Handle_Mouse (Dialog.Cancel, Event => Mouse_Event_Type'First);
end;
procedure Do_Update_OK_Button
(Dialog : access Font_Dialog'Class) is
Font_Name : constant String :=
Get_Text (Dialog.Font_Name);
begin
Put_Line ("OK button pressed; font name is '" &
Font_Name &
"'");
null; -- do something with font name
Hide (Dialog.all);
end Do_Update_OK_Button;
procedure Do_Update_Cancel_Button
(Dialog : access Font_Dialog'Class) is
begin
Put_Line ("Cancel button pushed");
Hide (Dialog.all);
end;
procedure Do_Update_Font_List
(Dialog : access Font_Dialog) is
Font_List : List_Box_Widget renames
Dialog.Font_List;
Font_Name : Entry_Field_Widget renames
Dialog.Font_Name;
begin
Set_Text (Font_Name, Text => Get_Selection (Font_List));
end;
procedure Update
(Dialog : access Font_Dialog;
Widget : access Widget_Type'Class) is
type Widget_Access is access constant Widget_Type'Class;
for Widget_Access'Storage_Size use 0;
WA : constant Widget_Access := Widget_Access (Widget);
begin
if WA = Dialog.OK'Access then
Do_Update_OK_Button (Dialog);
elsif WA = Dialog.Cancel'Access then
Do_Update_Cancel_Button (Dialog);
elsif WA = Dialog.Font_List'Access then
Do_Update_Font_List (Dialog);
elsif WA = Dialog.Font_Name'Access then
null;
else
raise Program_Error;
end if;
end Update;
end Font_Dialogs;
with Widgets.Buttons;
with Widgets.List_Boxes;
with Widgets.Entry_Fields;
package Font_Dialogs is
type Font_Dialog is limited private;
procedure Show (Dialog : in out Font_Dialog);
procedure Hide (Dialog : in out Font_Dialog);
procedure Push_OK_Button (Dialog : in out Font_Dialog);
procedure Push_Cancel_Button (Dialog : in out Font_Dialog);
private
use Widgets;
use Widgets.Buttons;
use Widgets.List_Boxes;
use Widgets.Entry_Fields;
type Font_Dialog is
new Widget_Observer with record
OK : aliased Button_Widget (Font_Dialog'Access);
Cancel : aliased Button_Widget (Font_Dialog'Access);
Font_List : aliased List_Box_Widget (Font_Dialog'Access);
Font_Name : aliased Entry_Field_Widget (Font_Dialog'Access);
end record;
procedure Update
(Dialog : access Font_Dialog;
Widget : access Widget_Type'Class);
end Font_Dialogs;
with Font_Dialogs; use Font_Dialogs;
procedure Test_Mediator is
Dialog : Font_Dialog;
begin
Push_OK_Button (Dialog);
Push_Cancel_Button (Dialog);
end Test_Mediator;
package body Widgets.Buttons is
procedure Handle_Mouse
(Widget : in out Button_Widget;
Event : in Mouse_Event_Type) is
begin
Update (Widget.Observer, Widget'Access);
end;
end Widgets.Buttons;
package Widgets.Buttons is
type Button_Widget is new Widget_Type with private;
procedure Handle_Mouse
(Widget : in out Button_Widget;
Event : in Mouse_Event_Type);
private
type Button_Widget is
new Widget_Type with null record;
end Widgets.Buttons;
package body Widgets.Entry_Fields is
procedure Set_Text
(Widget : in out Entry_Field_Widget;
Text : in String) is
begin
null;
end;
function Get_Text
(Widget : Entry_Field_Widget) return String is
begin
return "current value of entry field";
end;
procedure Handle_Mouse
(Widget : in out Entry_Field_Widget;
Event : in Mouse_Event_Type) is
begin
null;
end;
end Widgets.Entry_Fields;
package Widgets.Entry_Fields is
type Entry_Field_Widget is
new Widget_Type with private;
procedure Set_Text
(Widget : in out Entry_Field_Widget;
Text : in String);
function Get_Text
(Widget : Entry_Field_Widget) return String;
procedure Handle_Mouse
(Widget : in out Entry_Field_Widget;
Event : in Mouse_Event_Type);
private
type Entry_Field_Widget is
new Widget_Type with null record;
end Widgets.Entry_Fields;
package body Widgets.List_Boxes is
function Get_Selection
(Widget : List_Box_Widget) return String is
begin
return "value of current selection";
end;
procedure Handle_Mouse
(Widget : in out List_Box_Widget;
Event : in Mouse_Event_Type) is
begin
null;
end;
end Widgets.List_Boxes;
package Widgets.List_Boxes is
type List_Box_Widget is
new Widget_Type with private;
function Get_Selection
(Widget : List_Box_Widget) return String;
procedure Handle_Mouse
(Widget : in out List_Box_Widget;
Event : in Mouse_Event_Type);
private
type List_Box_Widget is
new Widget_Type with null record;
end Widgets.List_Boxes;
package body Widgets is
procedure Update
(Observer : access Widget_Observer;
Widget : access Widget_Type'Class) is
begin
null;
end;
procedure Handle_Mouse
(Widget : in out Widget_Type;
Event : in Mouse_Event_Type) is
begin
null;
end;
end Widgets;
package Widgets is
type Widget_Observer is tagged limited null record;
type Widget_Type (Observer : access Widget_Observer'Class) is
tagged limited private;
procedure Update
(Observer : access Widget_Observer;
Widget : access Widget_Type'Class);
type Mouse_Event_Type is new Integer;
procedure Handle_Mouse
(Widget : in out Widget_Type;
Event : in Mouse_Event_Type);
private
type Widget_Type (Observer : access Widget_Observer'Class) is
tagged limited null record;
end Widgets;
|
