A mediator coordinates component interaction.
In this example we build a user interface dialog box to select a font.
Double-clicking on the font list displays the selected font in the text
entry area. Clicking on the OK button selects the font listed in the
text field, and pops the dialog down.
Components of the dialog don't communicate with each other directly.
Instead, they report state changes to the dialog (the mediator), who
handles the update itself. This simplifies mental reasoning about
control flow.
Implementation
We use a widget observer to handle the updates reported by dialog
components. Widget subjects bind to their observer via an access
discriminant:
package Widgets is
type Widget_Observer is tagged limited null record;
procedure Update (Observer : access Widget_Observer);
type Widget_Type (Observer : access Widget_Observer'Class) is
tagged limited private;
...
end Widgets;
A widget reports a state change to its observer by calling Update, which
has a default implementation that does nothing.
There are a couple of choices for the implementation of the font dialog:
1) implement the font dialog as an observer, and bind each of its widget
components to the dialog itself; or,
2) implement the font dialog as a record with observer components, and
bind each widget to its own separate observer.
The first implementation would require that you pass the widget as an
argument of Update, which you would then interrogate in order to
determine which widget signalled the change.
However, this violates the principle that a subprogram should do only
one thing, since the Update operation for the dialog observer would have
to service different requests from all of the myriad widgets.
There's a better way. Instead of passing a tag into a large subprogram
to tell it which function to perform ("control coupling"), just call the
function directly. I have therefore chosen to use the second technique,
so that each observer has its own separate Update operation.
The font dialog looks like this:
package Font_Dialogs is
type Font_Dialog is limited private;
...
private
...
type Font_Dialog is
limited record
OK_Button : OK_Button_Observer (Font_Dialog'Access);
Cancel_Button : Cancel_Button_Observer (Font_Dialog'Access);
Font_List : Font_List_Observer (Font_Dialog'Access);
Font_Name : Font_Name_Observer (Font_Dialog'Access);
end record;
end Font_Dialogs;
Each observer type extends the root type with two new components. The
first is an access discriminant designating the font dialog, which gives
the observer access to the other widgets in the same dialog instance.
The second component is the widget being observed.
For example, here's the type that observes the OK button widget:
type OK_Button_Observer (Dialog : access Font_Dialog) is
new Widget_Observer with record
Button : Button_Widget (OK_Button_Observer'Access);
end record;
procedure Update (Observer : access OK_Button_Observer);
The font list widget tells its observer when the user double-clicks on
an item in the list. The dialog responds by querying the font list for
the value of the selected item, and then using that as the value of the
text entry field:
procedure Update (Observer : access Font_List_Observer) is
Font_List : List_Box_Widget renames
Observer.List_Box;
Font_Name : Entry_Field_Widget renames
Observer.Dialog.Font_Name.Entry_Field;
begin
Set_Text (Font_Name, Text => Get_Selection (Font_List));
end;
Notice how the access discriminant of the font list observer allows it
to reach up into dialog, and then down into the font name component.
When you click the OK button, the button notifies its observer, who
queries the text entry widget for the value of the font name, does the
font selection, and then dismisses the dialog:
procedure Update (Observer : access OK_Button_Observer) is
Font_Name : constant String :=
Get_Text (Observer.Dialog.Font_Name.Entry_Field);
begin
<process font name>
Hide (Observer.Dialog.all);
end Update;
This is an example of the "multiple views" idiom discussed in the Ada95
Rationale. A widget views the object as an observer, while the observer
views the object as a widget. This largely obviates the need for
multiple inheritance.
The following code is ready for GNAT Chop:
--STX
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 Update (Observer : access OK_Button_Observer) is
Font_Name : constant String :=
Get_Text (Observer.Dialog.Font_Name.Entry_Field);
begin
null; -- do something with font name
Hide (Observer.Dialog.all);
end Update;
procedure Update (Observer : access Cancel_Button_Observer) is
begin
Hide (Observer.Dialog.all);
end;
procedure Update (Observer : access Font_List_Observer) is
Font_List : List_Box_Widget renames
Observer.List_Box;
Font_Name : Entry_Field_Widget renames
Observer.Dialog.Font_Name.Entry_Field;
begin
Set_Text (Font_Name, Text => Get_Selection (Font_List));
end;
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);
private
use Widgets;
use Widgets.Buttons;
use Widgets.List_Boxes;
use Widgets.Entry_Fields;
type OK_Button_Observer (Dialog : access Font_Dialog) is
new Widget_Observer with record
Button : Button_Widget (OK_Button_Observer'Access);
end record;
procedure Update (Observer : access OK_Button_Observer);
type Cancel_Button_Observer (Dialog : access Font_Dialog) is
new Widget_Observer with record
Button : Button_Widget (Cancel_Button_Observer'Access);
end record;
procedure Update (Observer : access Cancel_Button_Observer);
type Font_List_Observer (Dialog : access Font_Dialog) is
new Widget_Observer with record
List_Box : List_Box_Widget (Font_List_Observer'Access);
end record;
procedure Update (Observer : access Font_List_Observer);
type Font_Name_Observer (Dialog : access Font_Dialog) is
new Widget_Observer with record
Entry_Field : Entry_Field_Widget (Font_Name_Observer'Access);
end record;
type Font_Dialog is
limited record
OK_Button : OK_Button_Observer (Font_Dialog'Access);
Cancel_Button : Cancel_Button_Observer (Font_Dialog'Access);
Font_List : Font_List_Observer (Font_Dialog'Access);
Font_Name : Font_Name_Observer (Font_Dialog'Access);
end record;
end Font_Dialogs;
package body Widgets.Buttons is
procedure Handle_Mouse
(Widget : in out Button_Widget;
Event : in Mouse_Event_Type) is
begin
Update (Widget.Observer);
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) 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;
procedure Update (Observer : access Widget_Observer);
type Widget_Type (Observer : access Widget_Observer'Class) is
tagged limited private;
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;
|
