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

["Lucretia" <lucretia9@lycos.co.uk>]

Hi,

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. 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'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

Thanks,
Luke.

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;

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;
  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

        Update(Observer_Lists.Element(Current), Event);

        --Observer_Lists.Element(Current).Update;

        Current := Observer_Lists.Next(Current);

      end if;

    end loop;

  end Notify;


--  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;

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;
  procedure Notify(Self : in Subject; Event : in Events.Event);

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;