Mediator Pattern - Alternate Implementation

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;