The Observer pattern binds observers to a subject, so that when the
subject changes state, it notifies all of its observers.
A classic example of this pattern is the Smalltalk Model-View-Controller
framework. The view observers are all kept separate from the model
subject, which simplifies the model because it doesn't have to worry
about how it gets displayed.
Implementation
The subject and observer are a highly cohesive pair of types. The
subject needs access to the representation of observer, so it can create
a storage-efficient observer list. And the observer needs access to
private operations of the subject, so it can register (and unregister)
itself with the subject.
The subject and observer being mutually dependent this way means they
get declared together, in the same package:
package Subjects_And_Observers is
type Root_Subject_Type is
abstract tagged limited private;
procedure Notify
(Subject : in out Root_Subject_Type);
type Root_Observer_Type
(Subject : access Root_Subject_Type'Class) is
abstract tagged limited private;
procedure Update
(Observer : access Root_Observer_Type) is abstract;
...
end Subjects_And_Observers;
The observer type has an access discriminant designating the subject,
which guarantees that the subject will outlive its observer. This
eliminates dangling reference problems from observer to subject.
When the observer object elaborates, it registers itself with the
subject designated by the discriminant, which puts the observer on an
internal list:
type Root_Subject_Type is
abstract tagged limited record
Observer_List : Observer_Access;
end record;
procedure Register
(Subject : access Root_Subject_Type;
Observer : access Root_Observer_Type'Class);
During observer finalization, the observer unregisters itself, and the
subject removes it from the list. Therefore, the subject doesn't ever
have to worry about accessibility of an observer in an inner scope.
This eliminates dangling reference problems from subject to observer.
This guarantee by the observer that it's always accessible means we can
suppress accessibility and access checks:
type Observer_Access is access all Root_Observer_Type'Class;
pragma Suppress (Accessibility_Check, On => Observer_Access);
pragma Suppress (Access_Check, On => Observer_Access);
In fact we must do this, or Program_Error will be raised as soon as we
try to convert an access object designating an observer in an inner
scope.
The observer type privately derives from Limited_Controlled and
overrides Initialize and Finalize:
type Root_Observer_Type (Subject : access Root_Subject_Type'Class) is
abstract new Limited_Controlled with record
Next : Observer_Access;
end record;
procedure Initialize (Observer : in out Root_Observer_Type);
procedure Finalize (Observer : in out Root_Observer_Type);
This allows the observer to automatically register and unregister itself
with a subject. In the implementation of Initialize (and similarly for
Finalize), the observer passes itself as a parameter of the subject's
private register operation:
procedure Initialize (Observer : in out Root_Observer_Type) is
begin
Register (Observer.Subject, Observer'Access);
end;
The observer can "see" a subject because it designates one via an access
discriminant. That's why Register and Unregister take subject an access
parameter, so the observer can refer its subject in a natural way,
without an explicit dereference.
The Next component of the observer type is used to link the observer on
the subject's observer list. Note that this is not a list of nodes that
point to observers -- it is a linked list of actual observer objects. I
use this idiom all the time.
When the subject is told to notify its observers, it traverses the
observer list updating each observer in turn:
procedure Notify (Subject : in out Root_Subject_Type) is
Observer : Observer_Access := Subject.Observer_List;
begin
while Observer /= null loop
Update (Observer);
Observer := Observer.Next;
end loop;
end Notify;
That explains the basics of abstract subjects and observers, so let's
move on to the example. The concrete subject is a timer with operations
to set the current time and return the time components:
package Clock_Timers is
type Clock_Timer is new Root_Subject_Type with private;
procedure Tick (Timer : in out Clock_Timer);
function Get_Hour (Timer : Clock_Timer) return Hour_Number;
...
end Clock_Timers;
It publicly derives from the subject type, because observers have to
know they're pointing to a type in the subject class.
When a clock tick happens, the clock updates its internal state
(comprising the current hour, minute, and second), and notifies its
observers that the time has changed:
procedure Tick (Timer : in out Clock_Timer) is
Current_Time : constant Time := Clock;
begin
<update state>
Notify (Timer); <--
end Tick;
The observer is a digital clock that displays the time whenever it gets
updated by its clock timer subject.
The interesting issue here is how a clock binds to a timer type
specifically, instead of to just any type in the subject class.
We saw in the Subjects_And_Observers package how the observer type took
an access discriminant designating Root_Subject_Type'Class. But the
digital clock observer needs to point to an object in the Clock_Timer
class, not just Root_Subject_Type class. Otherwise, it would have no
way of calling clock timer operations without an ugly, unsafe downcast.
What we do is declare a clock timer discriminant for digital clock,
replacing the discriminant it inherited from root observer:
package Digital_Clocks is
type Digital_Clock (Timer : access Clock_Timer'Class) is
new Root_Observer_Type with private;
...
private
type Digital_Clock (Timer : access Clock_Timer'Class) is
new Root_Observer_Type (Timer) with null record;
end Digital_Clocks;
This is legal because the clock timer is in the subject class -- that's
why we needed to publicly derive clock timer from subject. (For esoteric
reasons, the actual replacement of the parent's discriminant can only be
done in the private region of the spec.)
Now that digital clock can see clock timers, it can legally use timer
operations to query its timer subject:
procedure Update (Clock : access Digital_Clock) is
Hour_Image : constant String :=
Integer'Image (Get_Hour (Clock.Timer.all) + 100);
^^^^^^^^
Minute_Image : constant String :=
Integer'Image (Get_Minute (Clock.Timer.all) + 100);
^^^^^^^^^^
Second_Image : constant String :=
Integer'Image (Get_Second (Clock.Timer.all) + 100);
^^^^^^^^^^
...
end Update;
At different times in the test driver, there are one, two, and three
clock observers bound to the same timer subject. When a tick happens,
you get a corresponding number of time displays.
--STX
with Ada.Calendar; use Ada.Calendar;
package body Clock_Timers is
procedure Tick (Timer : in out Clock_Timer) is
Current_Time : constant Time := Clock;
Current_Seconds : constant Natural :=
Natural (Seconds (Current_Time));
begin
Timer.Hour := Current_Seconds / 3600;
Timer.Minute := (Current_Seconds - 3600 * Timer.Hour) / 60;
Timer.Second :=
Current_Seconds -
3600 * Timer.Hour -
60 * Timer.Minute;
Notify (Timer);
end Tick;
function Get_Hour (Timer : Clock_Timer) return Hour_Number is
begin
return Timer.Hour;
end;
function Get_Minute (Timer : Clock_Timer) return Minute_Number is
begin
return Timer.Minute;
end;
function Get_Second (Timer : Clock_Timer) return Second_Number is
begin
return Timer.Second;
end;
end Clock_Timers;
with Subjects_And_Observers; use Subjects_And_Observers;
package Clock_Timers is
type Clock_Timer is new Root_Subject_Type with private;
procedure Tick (Timer : in out Clock_Timer);
subtype Hour_Number is Natural range 0 .. 23;
function Get_Hour (Timer : Clock_Timer) return Hour_Number;
subtype Minute_Number is Natural range 0 .. 59;
function Get_Minute (Timer : Clock_Timer) return Minute_Number;
subtype Second_Number is Natural range 0 .. 59;
function Get_Second (Timer : Clock_Timer) return Second_Number;
private
type Clock_Timer is
new Root_Subject_Type with record
Hour : Hour_Number;
Minute : Minute_Number;
Second : Second_Number;
end record;
end Clock_Timers;
with Ada.Text_IO; use Ada.Text_IO;
package body Digital_Clocks is
procedure Update (Clock : access Digital_Clock) is
Hour_Image : constant String :=
Integer'Image (Get_Hour (Clock.Timer.all) + 100);
Minute_Image : constant String :=
Integer'Image (Get_Minute (Clock.Timer.all) + 100);
Second_Image : constant String :=
Integer'Image (Get_Second (Clock.Timer.all) + 100);
Clock_Image : constant String :=
Hour_Image (3 .. Hour_Image'Last) & ":" &
Minute_Image (3 .. Minute_Image'Last) & ":" &
Second_Image (3 .. Second_Image'Last);
begin
Put_Line (Clock_Image);
end Update;
end Digital_Clocks;
with Clock_Timers; use Clock_Timers;
with Subjects_And_Observers; use Subjects_And_Observers;
package Digital_Clocks is
type Digital_Clock (Timer : access Clock_Timer'Class) is
new Root_Observer_Type with private;
procedure Update (Clock : access Digital_Clock);
private
type Digital_Clock (Timer : access Clock_Timer'Class) is
new Root_Observer_Type (Timer) with null record;
end Digital_Clocks;
package body Subjects_And_Observers is
procedure Notify (Subject : in out Root_Subject_Type) is
Observer : Observer_Access := Subject.Observer_List;
begin
while Observer /= null loop
Update (Observer);
Observer := Observer.Next;
end loop;
end Notify;
procedure Register
(Subject : access Root_Subject_Type;
Observer : access Root_Observer_Type'Class) is
begin
Observer.Next := Subject.Observer_List;
Subject.Observer_List := Observer_Access (Observer);
end;
procedure Unregister
(Subject : access Root_Subject_Type;
Observer : access Root_Observer_Type'Class) is
OA : constant Observer_Access := Observer_Access (Observer);
Prev : Observer_Access;
Index : Observer_Access;
begin
if Subject.Observer_List = OA then
Subject.Observer_List := Subject.Observer_List.Next;
else
Prev := Subject.Observer_List;
Index := Prev.Next;
while Index /= OA loop
Prev := Index;
Index := Index.Next;
end loop;
Prev.Next := Index.Next;
end if;
end Unregister;
procedure Initialize (Observer : in out Root_Observer_Type) is
begin
Register (Observer.Subject, Observer'Access);
end;
procedure Finalize (Observer : in out Root_Observer_Type) is
begin
Unregister (Observer.Subject, Observer'Access);
end;
end Subjects_And_Observers;
with Ada.Finalization;
package Subjects_And_Observers is
type Root_Subject_Type is
abstract tagged limited private;
procedure Notify (Subject : in out Root_Subject_Type);
type Root_Observer_Type (Subject : access Root_Subject_Type'Class) is
abstract tagged limited private;
procedure Update (Observer : access Root_Observer_Type) is abstract;
private
type Observer_Access is access all Root_Observer_Type'Class;
pragma Suppress (Accessibility_Check, On => Observer_Access);
pragma Suppress (Access_Check, On => Observer_Access);
type Root_Subject_Type is
abstract tagged limited record
Observer_List : Observer_Access;
end record;
procedure Register
(Subject : access Root_Subject_Type;
Observer : access Root_Observer_Type'Class);
procedure Unregister
(Subject : access Root_Subject_Type;
Observer : access Root_Observer_Type'Class);
use Ada.Finalization;
type Root_Observer_Type (Subject : access Root_Subject_Type'Class) is
abstract new Limited_Controlled with record
Next : Observer_Access;
end record;
procedure Initialize (Observer : in out Root_Observer_Type);
procedure Finalize (Observer : in out Root_Observer_Type);
end Subjects_And_Observers;
with Clock_Timers; use Clock_Timers;
with Digital_Clocks; use Digital_Clocks;
with Ada.Text_IO; use Ada.Text_IO;
procedure Test_Observers is
Timer : aliased Clock_Timer;
Clock : Digital_Clock (Timer'Access);
procedure Do_Ticks is
begin
delay 1.0;
Tick (Timer);
delay 2.0;
Tick (Timer);
delay 3.0;
Tick (Timer);
New_Line;
end Do_Ticks;
begin
Do_Ticks;
declare
Another_Clock : Digital_Clock (Timer'Access);
begin
Do_Ticks;
declare
Yet_Another_Clock : Digital_Clock (Timer'Access);
begin
Do_Ticks;
end;
Do_Ticks;
end;
Do_Ticks;
end Test_Observers;
|
