I'm trying to implement an Observer pattern using OOP and dynamic dispatching, but I'm not able to create an access-to-subprogram constant because the argument types of the named access and the procedure of the type extension don't match.
I provide a minimal reproducibable example, ommiting subscription:
package Alarms is
type time_t is mod 2**32;
type AlarmObserver_t is interface;
type Callback_t is access procedure (this : in out AlarmObserver_t);
type AlarmPublisher_t (<>) is tagged limited private;
function fConstructor (capacity : in Positive) return AlarmPublisher_t;
private
type AlarObserverAcc_t is access AlarmObserver_t'Class;
type dummy_t is new AlarmObserver_t with null record;
procedure pEventDummy (this : in out dummy_t) is Null;
dummy : constant AlarObserverAcc_t := new dummy_t;
dummyCallback : constant Callback_t := pEventDummy'Access; --Fails
type Node_t is limited
record
Observer : AlarObserverAcc_t := dummy;
Callback : Callback_t := dummyCallback;
time : time_t := time_t'Last;
end record;
defaultNode : constant Node_t := Node_t' (Observer => dummy,
Callback => dummyCallback,
time => time_t'Last);
type ObserverArray_t is array (Positive range <>) of Node_t;
type AlarmPublisher_t (capacity : Positive) is tagged limited
record
--Member "observers" has default initialisation because Node_t is initialised
observers : ObserverArray_t (Positive'First .. capacity);
end record;
end Alarms;
And the implementation to let you reproduce it:
package body Alarms is
function fConstructor (capacity : in Positive) return AlarmPublisher_t is
begin
return Obj : AlarmPublisher_t (capacity => capacity) do
Null;
end return;
end fConstructor;
end Alarms;
I was inspiring in Matthew Heaney callbacks Observer pattern
He use a class-wide argument for the access-to-subprogram procedure, but I would like to use OOP notation and let the concrete observers to have those procedures as primitives.
Why procedure pEventDummy is not compatible if dummy_t implements AlarmObserver_t interface? Can I do what I want?
I provide an example below to show what I would like to do. I want concrete observers to be flexible and allow them to subscribe to the method they want to be notified when the subscribed alarm expires. I don't know in advance which primitives will be used for that purpose so I don't want to type all the possibilities as abstract primitives of the AlarmObserver_t interface, I would like let the concrete observers to subscribe to an access to procedure for that purpose, and they will be notified through them at different moments:
with Alarms;
package ConcreteObserver is
type ConcreteObserver_t is new Alarms.AlarmObserver_t with private;
--Procedure evTimeout to be notified for an alarm expirancy.
--Null implementation to let you compile
procedure evTimeout (this : in out ConcreteObserver_t) is null;
--Procedure evAnotherTimeout to be notified for another alarm expirancy
--Null implementation to let you compile
procedure evAnotherTimeout (this : in out ConcreteObserver_t) is null;
private
--This will fail as dummyCallback in Alarms package
evTimeoutCallback : constant Alarms.Callback_t := evTimeout'Access;
--This will fail as dummyCallback in Alarms package
evAnotherTimeoutCallback : constant Alarms.Callback_t := evAnotherTimeout'Access;
type ConcreteObserver_t is new Alarms.AlarmObserver_t with
record
--Any attribute
Null;
end record;
end ConcreteObserver;
I would suggest adding a polymorphic operation to your interface type:
package Alarms is
type time_t is mod 2**32;
type AlarmObserver_t is interface;
type TimeoutObserver is interface and AlarmObserver_t;
procedure Timeout_Callback(This : in out TimeoutObserver) is abstract; -- polymorphic operation
type AnotherTimeoutObserver is interface and AlarmObserver_t;
procedure AnotherTimeout_Callback(This : in out AnotherTimeoutObserver) is abstract; -- polymorphic operation
type AlarmPublisher_t (<>) is tagged limited private;
function fConstructor (capacity : in Positive) return AlarmPublisher_t;
private
type AlarObserverAcc_t is access AlarmObserver_t'Class;
type dummy_t is new TimeoutObserver and AnotherTimeoutObserver with null record;
overriding procedure Timeout_Callback(This : in out dummy_t) is null; -- local type override
overriding procedure AnotherTimeout_Callback(This : in out dummy_t) is null; -- local type override
dummy : constant AlarObserverAcc_t := new dummy_t;
type Node_t is limited
record
Observer : AlarObserverAcc_t := dummy;
time : time_t := time_t'Last;
end record;
defaultNode : constant Node_t := Node_t' (Observer => dummy,
time => time_t'Last);
type ObserverArray_t is array (Positive range <>) of Node_t;
type AlarmPublisher_t (capacity : Positive) is tagged limited
record
--Member "observers" has default initialisation because Node_t is initialised
observers : ObserverArray_t (Positive'First .. capacity);
end record;
end Alarms;
package body Alarms is
function fConstructor (capacity : in Positive) return AlarmPublisher_t is
begin
return Obj : AlarmPublisher_t (capacity => capacity) do
Null;
end return;
end fConstructor;
end Alarms;
with Alarms;
package ConcreteObserver is
type ConcreteObserver_t is new
Alarms.TimeoutObserver
and Alarms.AnotherTimeoutObserver
with private;
--Procedure evTimeout to be notified for an alarm expirancy.
--Null implementation to let you compile
overriding
procedure Timeout_Callback (this : in out ConcreteObserver_t) is null;
--Procedure evAnotherTimeout to be notified for another alarm expirancy
--Null implementation to let you compile
overriding
procedure AnotherTimeout_Callback (this : in out ConcreteObserver_t) is null;
private
type ConcreteObserver_t is new
Alarms.TimeoutObserver
and Alarms.AnotherTimeoutObserver
with
record
--Any attribute
Null;
end record;
end ConcreteObserver;
You can use Object.Operation notation to call Callback for your AlarmPublisher_t object. EX:
for Node of Observers loop
if Node.observer in TimeoutObserver'Class then
TimeoutObserver'Class(Node.observer).Timout_Callback;
end if;
if Node.observer in AnotherTimeoutObserver'Class then
AnotherTimeoutObserver'Class(Node.observer).AnotherTimeout_Callback;
end if;
end loop;