Re: Ada 2005: Attempting to create a useful subject/observer pattern

["Dmitry A. Kazakov" <mailbox@dmitry-kazakov.de>]

On 24 Oct 2006 14:01:50 -0700, Lucretia wrote:

> Like the subject states, I'm trying to implement a usable
> subject/observer pattern which is an extension of the GoF original and
> something closer to Java's Listeners.

yuck...

> The idea was to use the code in a
> gui library. After talking on IRC (#Ada) and working with the guys
> there (Baldrick ;D), it was noted that GNAT is flawed in it's
> interfaces, but I'd like to know if anyone here can indicate whether
> the code is wrong and GNAT should accept it or not.

I cannot comment on compiler bugs, I am not a language lawyer. So I only
comment on to the code.

> I'm using FSF GNAT from GCC 4.1.1 and the errors are:
> 
> gnatmake -gnat05 test_observers2.adb
> gcc -c -gnat05 test_observers2.adb
> test_observers2.adb:16:34: (Ada 2005) interface subprogram "Update"
> must be abstract or null
> test_observers2.adb:23:31: expected private type "Event" defined at
> events.ads:5test_observers2.adb:23:31: found private type "Mouse_Event"
> defined at mouse_events.ads:5
> my_observer.ads:10:03: (Ada 2005) interface subprogram "On_Mouse_Click"
> must be abstract or null
> subjects.ads:15:10: (Ada 2005) interface subprogram "Update" must be
> abstract or null
> subjects.ads:15:20: operation can be dispatching in only one type
> gnatmake: "test_observers2.adb" compilation error
> 
> All code below is GPL'd and can be gnatchopped:
> 
> with Ada.Finalization;
> package Events is
>   type Event is new Ada.Finalization.Controlled with private;
> private
>   type Event is new Ada.Finalization.Controlled with null record;
> end Events;
>
> with Events; 
> package Mouse_Events is
>   type Mouse_Event is new Events.Event with private;
> private 
>   type Mouse_Event is new Events.Event with null record;
> end Mouse_Events;
>
> with Mouse_Events;
> with Observers; 
> package Mouse_Observers is
>   type Mouse_Observer is interface and Observers.Observer;
>   procedure On_Mouse_Click(Self : in Mouse_Observer; Event : in
> Mouse_Events.Mouse_Event) is null;

I suppose this should be:

procedure On_Mouse_Click
          (  Self  : in Mouse_Observer;
             Event : in Mouse_Events.Mouse_Event'Class
          )  is null;

> end Mouse_Observers;
>
> with Ada.TexT_IO; 
> package body My_Observer is
> --  procedure Update(Self : in My_Observer_Type) is
> --  begin
> --    Ada.TexT_IO.Put_Line("[My_Observer.Update]");
> --  end Update;
> 
>   procedure On_Mouse_Click(Self : in Mouse_Observer; Event : in
> Mouse_Events.Mouse_Event) is
>   begin
>     Ada.TexT_IO.Put_Line("[My_Observer.On_Mouse_Click]");
>   end On_Mouse_Click;
> end My_Observer;
>
> with Mouse_Observers;
> with Mouse_Events;
> package My_Observer is
>   type My_Observer_Type is new Mouse_Observers.Mouse_Observer with
> private; 
>   overriding
> --  procedure Update(Self : in My_Observer_Type);
>   procedure On_Mouse_Click(Self : in Mouse_Observers.Mouse_Observer;
> Event : in Mouse_Events.Mouse_Event);
> 
> private
>   type My_Observer_Type is new Mouse_Observers.Mouse_Observer with null
> record;
> end My_Observer;
>
> package Observers is 
>   type Observer is interface;

Why don't you define abstract Notify on Observer? Why Observer need to be
an interface? What does guarantee detachment of observers upon
finalization?

>   type Observer_Access is access all Observer'Class;
> end Observers;
>
> with Observers;
> 
> package body Subjects is
>   use type Observer_Lists.Cursor;
>   -- Add an observer to this subject's internal list.
>   procedure Attach(Self : in out Subject'Class; Observer : access
> Observers.Observer'Class) is
>   begin
>     Self.Observer_List.Append(New_Item =>
> Observers.Observer_Access(Observer));
>   end Attach;
> 
>   -- Remove an observer from this subject's internal list.
>   procedure Detach(Self : in out Subject'Class; Observer : access
> Observers.Observer'Class) is
> 
>     Position : Observer_Lists.Cursor :=
> Self.Observer_List.Find(Observers.Observer_Access(Observer));
>   begin
>     if Position /= Observer_Lists.No_Element then
>       Self.Observer_List.Delete(Position);
>     end if;
>   end Detach;
> 
>   -- Notify all observers who are monitoring this subject that
> something has happened.
>   procedure Notify(Self : in Subject; Event : in Events.Event) is
> 
>     Current : Observer_Lists.Cursor := Self.Observer_List.First;
>   begin
>     while Current /= Observer_Lists.No_Element loop
>       if Observer_Lists.Element(Current)'Class = Matching_Event'Class
> then

This should be something like:

if Observer_Lists.Element (Current) in Matching_Event'Class then

However, I would not use a design that queues events to [ultimate]
observers. Rather I would queue observers to the event sources. That would
save me event filtering issue, as well as crude emulations of multiple
dispatch like you tried above.

>         Update(Observer_Lists.Element(Current), Event);
>         --Observer_Lists.Element(Current).Update;
>         Current := Observer_Lists.Next(Current);
>       end if;
>     end loop;
>   end Notify;

There is a big problem with traversing the list of observers, while calling
notifications. If some of the notification causes a list change? This is a
no-no with Ada.Containers. So you have to undertake some actions to ensure
that this would never happen. Unfortunately it is necessary to happen. I
usually add some parameters to Update, to allow the subscribers to postpone
some notifications from the callback. But this is a complex issue for such
a small example.

> --  function Equals(Left, Right : access Observers.Observer) return
> Boolean is
>   function Equals(Left, Right : Observers.Observer_Access) return
> Boolean is
>     use type Observers.Observer_Access;
>   begin
>     if Left = Right then
>       return True;
>     end if;
>     return False;
>   end Equals;

My rule of thumb: If objects have referential identity => they have to be
limited. So I would make Observer Limited_Controlled, if I wished to
compare pointers to them.

> end Subjects;
> with Observers;
> with Ada.Containers.Doubly_Linked_Lists;
> with Ada.Finalization;
> with Events;
> 
> package Subjects is
> 
>   type Subject is new Ada.Finalization.Limited_Controlled with private;
> 
>   procedure Attach(Self : in out Subject'Class; Observer : access
> Observers.Observer'Class);
>   procedure Detach(Self : in out Subject'Class; Observer : access
> Observers.Observer'Class);
> 
>   generic
>     type Matching_Event is new Events.Event with private;
>     with procedure Update(Self : in Observers.Observer; Event : in
> Events.Event) is abstract;

   ... Matching_Event'Class, I suppose.

>   procedure Notify(Self : in Subject; Event : in Events.Event);

procedure Notify(Self : in Subject'Class; Event : in Events.Event'Class);

Another empirical rule: if a subprogram takes tagged arguments and is not
primitive (or maybe located in a body), then it should be class-wide.

And, well, generics to hide type casting ... 

> private
> 
>   function Equals(Left, Right : Observers.Observer_Access) return
> Boolean;
> 
>   package Observer_Lists is new
> Ada.Containers.Doubly_Linked_Lists(Observers.Observer_Access, Equals);
> 
>   type Subject is new Ada.Finalization.Limited_Controlled with
>     record
>       Observer_List : Observer_Lists.List;
>     end record;
> 
> end Subjects;
> with My_Observer;
> with Subjects;
> --with Observers;
> with Mouse_Events;
> 
> procedure Test_Observers2 is
> 
> --  Obs     : Observers.Observer_Access := new
> My_Observer.My_Observer_Type;
> --  Obs     : access Observers.Observer := new
> My_Observer.My_Observer_Type;
>   Obs         : aliased My_Observer.My_Observer_Type;
>   Subject     : Subjects.Subject;
>   Mouse_Event : Mouse_Events.Mouse_Event;
> 
>   procedure Notify_Mouse_Click is new Subjects.Notify(
>     Matching_Event => Mouse_Events.Mouse_Event,
>     Update         => My_Observer.On_Mouse_Click);
> 
> begin
>   Subject.Attach(Obs'Access);
> --  Subject.Attach(Observers.Observer(Obs)'Access);
> --  Subject.Notify;
>   Notify_Mouse_Click(Subject, Mouse_Event);
>   
> end Test_Observers2;

-- 
Regards,
Dmitry A. Kazakov
http://www.dmitry-kazakov.de