I recently came into a basic OOP / Ada 2012 design issue.
Basically, I have a parent class that realizes an interface contract. This is done in several steps inside an implementation provider (ConcreteX). A child class extends this implementation by overriding only one of the steps (DerivedY, Step_2). (trying to get some SOLID properties)
I naively assumed that dispatching would occur. It doesn't. I rediscovered that dispatching is NOT like in Java or other OOP, and have come with a solution.
Dispatching in Ada is frequently asked/answered/documented in several questions: Dynamic dispatching in Ada, Dynamic Dispatching in Ada with Access Types, Fundamentals of Ada's T'Class
Instead of using:
This.Step_1; This.Step_2;
I ended up using:
T_Concrete_X'Class (This).Step_1; T_Concrete_X'Class (This).Step_2;
Within an Ada OOP class design, I'm struggling between those two choices:
In the parent class, define behavior + primitives and provide a default implementation i.e. Current_Class'Class(This).method() (= working example provided below)
Use a template design pattern so execution steps implementation is delegated to another class
i.e. in the given example:
-- T_Concrete_X does not have a child class (current example)
overriding procedure If_A_Proc_1 (This : in out T_Concrete_X) is
begin
-- This.template_executor being set with different classes realizing the Step_1/Step_2 contracts(current example)
This.template_executor.Step_1;
This.template_executor.Step_2;
end If_A_Proc_1;
Is 1 a syntaxic "trick" that should be avoided to achieve the intended behavior?
I always feel like when I write an explicit cast, that's a sign of weak design.
Working example:
src/interfacea.ads
package InterfaceA is
type T_InterfaceA is interface;
type T_InterfaceA_Class_Access is access all T_InterfaceA'Class;
procedure If_A_Proc_1 (This : in out T_InterfaceA) is abstract;
end InterfaceA;
src/concretex.ads
with InterfaceA;
use InterfaceA;
package ConcreteX is
type T_Concrete_X is new T_InterfaceA with private;
package Constructor is
function Create return access T_Concrete_X;
end Constructor;
overriding procedure If_A_Proc_1 (This : in out T_Concrete_X);
procedure Step_1 (This : in out T_Concrete_X);
procedure Step_2 (This : in out T_Concrete_X);
private
type T_Concrete_X is new T_InterfaceA with null record;
end ConcreteX;
src/concretex.adb
with GNATColl.Traces;
package body ConcreteX is
use GNATColl.Traces;
Me : constant Trace_Handle := Create ("ConcreteX");
package body Constructor is
function Create return access T_Concrete_X is begin
Set_Active (Me, True);
Increase_Indent (Me, "T_Concrete_X Constructor");
Decrease_Indent (Me);
return new T_Concrete_X;
end Create;
end Constructor;
overriding procedure If_A_Proc_1 (This : in out T_Concrete_X) is begin
Increase_Indent (Me, "If_A_Proc_1");
Trace (Me, "If_A_Proc_1 - use This directly");
-- not dispatching
This.Step_1;
This.Step_2;
-- dispatching
--Trace (Me, "If_A_Proc_1 - cast This to ConcreteX'Class");
--T_Concrete_X'Class (This).Step_1; -- equivalent to (This'Class).Step_1;
--T_Concrete_X'Class (This).Step_2; -- equivalent to (This'Class).Step_2;
Decrease_Indent (Me);
end If_A_Proc_1;
procedure Step_1 (This : in out T_Concrete_X) is begin
Increase_Indent (Me, "Step_1");
Decrease_Indent (Me);
end Step_1;
procedure Step_2 (This : in out T_Concrete_X) is begin
Increase_Indent (Me, "Step_2");
Decrease_Indent (Me);
end Step_2;
end ConcreteX;
src/concretex-derivedy.ads
package ConcreteX.DerivedY is
type T_Derived_Y is new T_Concrete_X with private;
package Constructor is
function Create return access T_Derived_Y;
end Constructor;
overriding procedure Step_2 (This : in out T_Derived_Y);
private
type T_Derived_Y is new T_Concrete_X with null record;
end ConcreteX.DerivedY;
src/concretex-derivedy.adb
with GNATColl.Traces;
package body ConcreteX.DerivedY is
use GNATColl.Traces;
Me : constant Trace_Handle := Create ("DerivedY");
package body Constructor is
function Create return access T_Derived_Y is begin
Set_Active (Me, True);
Increase_Indent (Me, "Constructor");
Decrease_Indent (Me);
return new T_Derived_Y;
end Create;
end Constructor;
overriding procedure Step_2 (This : in out T_Derived_Y) is begin
Increase_Indent (Me, "Step_2");
Decrease_Indent (Me);
end Step_2;
end ConcreteX.DerivedY;
src/main.adb
with InterfaceA;
with ConcreteX;
with ConcreteX.DerivedY;
with Ada.Text_IO;
with GNATColl.Traces;
procedure Main is
use ConcreteX;
use InterfaceA;
use Ada.Text_IO;
use GNATCOLL.Traces;
Me : constant Trace_Handle := Create ("MAIN");
C : T_InterfaceA'Class := T_InterfaceA'Class(Constructor.Create.all);
D : T_InterfaceA'Class := T_InterfaceA'Class(DerivedY.Constructor.Create.all);
begin
Parse_Config_File;
Set_Active (Me, True);
Trace (Me, "");
Trace (Me, "Call IF on C");
Trace (Me, "");
C.If_A_Proc_1;
Trace (Me, "");
Trace (Me, "Call IF on D");
Trace (Me, "");
D.If_A_Proc_1;
Trace (Me, "");
end Main;
inheritanceanddispatch.gpr
limited with "F:\DEV\GNAT\2017\lib\gnat\gnatcoll.gpr";
project Inheritanceanddispatch is
for Source_Dirs use ("src");
for Object_Dir use "obj";
for Main use ("main.adb");
for Exec_Dir use "exe";
end Inheritanceanddispatch;
Gnat versions:
GNAT GPL 2017 (20170515-63)
GPRBUILD GPL 2017 (20170515) (i686-pc-mingw32)
gcc (GCC) 6.3.1 20170510 (for GNAT GPL 2017 20170515)
Output:
[MAIN]
[MAIN] Call IF on C
[MAIN]
[CONCRETEX] If_A_Proc_1
[CONCRETEX] If_A_Proc_1 - use This directly
[CONCRETEX] Step_1
[CONCRETEX] Step_2
[CONCRETEX] If_A_Proc_1 - cast This to ConcreteX'Class
[CONCRETEX] Step_1
[CONCRETEX] Step_2
[MAIN]
[MAIN] Call IF on D
[MAIN]
[CONCRETEX] If_A_Proc_1
[CONCRETEX] If_A_Proc_1 - use This directly
[CONCRETEX] Step_1
[CONCRETEX] Step_2
[CONCRETEX] If_A_Proc_1 - cast This to ConcreteX'Class
[CONCRETEX] Step_1
[DERIVEDY] Step_2
[MAIN]
I personally wouldn't consider the cast to T_Concrete_X'Class so much as a syntactic trick. It's just the way to change the the view on the tagged type (type vs. type class). This "view conversion" i.e. T to T'Class (with T a tagged type) will always succeed and will not refine your view on the instance. It's not like (the more problematic) downcasting.
Regarding the two options: both are viable and it depends on your application (and probably preference) if you would take one or the other. The only difference I see is that the template pattern uses an abstract base class with abstract procedure that must be implemented by the derived type; i.e. you can't define a default implementation in your base class.
Besides the two options, you might also consider using composition instead of inheritance. Inheritance is in general less scalable once you need to vary more than one independent aspect (for now there is only one aspect, the steps, but you never know what needs to be added in the future). For this reason composition is often preferred over inheritance. Hence, you could also consider something like this:
action.ads
package Action is
type I_Action is interface;
procedure Action (This : I_Action) is abstract;
end Action;
exec.ads
with Action; use Action;
package Exec is
type T_Exec is new I_Action with private;
type T_Step_Fcn is access procedure (Exec : T_Exec'Class);
-- Possible implementations of steps. Note that these functions
-- are not primitives of T_Exec. Use the factory function of
-- T_Exec to composite the behavior of an instance of T_Exec.
-- Some OOP programmers would define a separate abstract (base) type
-- "T_Step" from which concrete step implementations will be derived.
-- I think this is too much in this case.
procedure No_Effect (Exec : T_Exec'Class) is null;
procedure Step_A (Exec : T_Exec'Class);
procedure Step_B (Exec : T_Exec'Class);
procedure Step_C (Exec : T_Exec'Class);
-- ...
-- Factory function.
function Create
(Step_1 : T_Step_Fcn := No_Effect'Access;
Step_2 : T_Step_Fcn := No_Effect'Access) return T_Exec;
overriding
procedure Action (This : T_Exec);
private
type T_Exec is new I_Action with
record
Step_1_Fcn : T_Step_Fcn;
Step_2_Fcn : T_Step_Fcn;
end record;
end Exec;
exec.adb
with Ada.Text_IO; use Ada.Text_IO;
package body Exec is
------------
-- Step_N --
------------
procedure Step_A (Exec : T_Exec'Class) is
begin
Put_Line ("Step_A");
end Step_A;
procedure Step_B (Exec : T_Exec'Class) is
begin
Put_Line ("Step_B");
end Step_B;
procedure Step_C (Exec : T_Exec'Class) is
begin
Put_Line ("Step_C");
end Step_C;
------------
-- Create --
------------
function Create
(Step_1 : T_Step_Fcn := No_Effect'Access;
Step_2 : T_Step_Fcn := No_Effect'Access) return T_Exec
is
begin
Put_Line ("Create");
return (Step_1, Step_2);
end Create;
------------
-- Action --
------------
procedure Action (This : T_Exec) is
begin
Put_Line ("Action");
This.Step_1_Fcn (This);
This.Step_2_Fcn (This);
end Action;
end Exec;
main.adb
with Ada.Text_IO; use Ada.Text_IO;
with Action; use Action;
with Exec; use Exec;
procedure Main is
begin
Put_Line ("---- Instance of T_Exec with Step A and Step B");
declare
A1 : I_Action'Class :=
Create (Step_1 => Step_A'Access,
Step_2 => Step_B'Access);
begin
A1.Action;
end;
New_Line;
Put_Line ("---- Instance of T_Exec with Step A and Step C");
declare
A2 : I_Action'Class :=
Create (Step_1 => Step_A'Access,
Step_2 => Step_C'Access);
begin
A2.Action;
end;
New_Line;
end Main;
output
---- Instance of T_Exec with Step A and Step B
Create
Action
Step_A
Step_B
---- Instance of T_Exec with Step A and Step C
Create
Action
Step_A
Step_C
Note: A final remark regarding the example in the question. You might as well remove all (anonymous) access types and "new" keywords and use
return T_Concrete_X'(null record);
or even
return (null record);
instead of
return new T_Concrete_X;