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

Question

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:

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]

score 5 · Accepted Answer

我个人不会将演员表T_Concrete_X'Class视为一种句法技巧。这只是更改标记类型（类型与类型类）的视图的方法。这种“视图转换”，即T到T'Class（带有T标记类型）将始终成功，并且不会优化您对实例的视图。这不像（更成问题的）垂头丧气。

关于这两个选项：两者都是可行的，如果您选择其中一个，则取决于您的应用程序（可能还有偏好）。我看到的唯一区别是模板模式使用抽象基类和必须由派生类型实现的抽象过程；即你不能在你的基类中定义一个默认的实现。

除了这两个选项之外，您还可以考虑使用组合而不是继承。一旦您需要改变多个独立方面（目前只有一个方面，即步骤，但您永远不知道将来需要添加什么），继承通常可扩展性较差。出于这个原因，组合通常比继承更受欢迎。因此，您还可以考虑这样的事情：

动作广告

package Action is

   type I_Action is interface;   
   procedure Action (This : I_Action) is abstract;

end Action;

执行广告

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;

执行亚行

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;

主文件

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;

输出

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

注意：关于问题中示例的最后评论。您不妨删除所有（匿名）访问类型和“新”关键字并使用

return T_Concrete_X'(null record);

甚至

return (null record);

代替

return new T_Concrete_X;

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

Context

Question

1 回答 1

Related

Reference