Mediator Pattern

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;