oopinheritanceadatemplate-method-patternada2012

Use Ada's My_Class'Class(This) cast to mimic template method design pattern


Context

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;

Question

Within an Ada OOP class design, I'm struggling between those two choices:

  1. In the parent class, define behavior + primitives and provide a default implementation i.e. Current_Class'Class(This).method() (= working example provided below)

  2. 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]

Solution

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