Visitor pattern: Difference between revisions

=={{header|Ada}}==

An Ada implementation of the Wikipedia Java example.

===Method 1: via Tagged Types (the object-oriented approach)===

Perhaps more packages than needed (7), which makes for quite a few files (specification + implementation). Only the `Visitors` files are long; the rest are much shorter.

<syntaxhighlight lang="ada">pragma Ada_2022;

package Base is

type Base_Record is abstract tagged null record;

end Base;

</syntaxhighlight>

<syntaxhighlight lang="ada">pragma Ada_2022;

limited with Base;

limited with Bodies;

limited with Cars;

limited with Engines;

limited with Wheels;

package Visitors is

type Visitor is abstract tagged null record;

procedure Visit_Base

(Self : Visitor; Dest : Base.Base_Record'Class) is null;

procedure Visit_Body (Self : Visitor; Dest : Bodies.Body_Record'Class);

procedure Visit_Car (Self : Visitor; Dest : Cars.Car_Record'Class);

procedure Visit_Engine (Self : Visitor; Dest : Engines.Engine_Record'Class);

procedure Visit_Wheel (Self : Visitor; Dest : Wheels.Wheel_Record'Class);

type Perform is new Visitor with null record;

type Print is new Visitor with null record;

overriding procedure Visit_Body

(Self : Perform; Dest : Bodies.Body_Record'Class);

overriding procedure Visit_Body

(Self : Print; Dest : Bodies.Body_Record'Class);

overriding procedure Visit_Car

(Self : Perform; Dest : Cars.Car_Record'Class);

overriding procedure Visit_Car (Self : Print; Dest : Cars.Car_Record'Class);

overriding procedure Visit_Engine

(Self : Perform; Dest : Engines.Engine_Record'Class);

overriding procedure Visit_Engine

(Self : Print; Dest : Engines.Engine_Record'Class);

overriding procedure Visit_Wheel

(Self : Perform; Dest : Wheels.Wheel_Record'Class);

overriding procedure Visit_Wheel

(Self : Print; Dest : Wheels.Wheel_Record'Class);

end Visitors;

</syntaxhighlight>

<syntaxhighlight lang="ada">pragma Ada_2022;

with Ada.Text_IO;

with Ada.Strings.Unbounded;

use all type Ada.Strings.Unbounded.Unbounded_String;

with Wheels;

package body Visitors is

package IO renames Ada.Text_IO;

procedure Visit_Body (Self : Visitor; Dest : Bodies.Body_Record'Class) is

begin

Self.Visit_Body (Dest);

end Visit_Body;

overriding procedure Visit_Body

(Self : Perform; Dest : Bodies.Body_Record'Class)

is

begin

IO.Put_Line ("Moving my Body");

end Visit_Body;

overriding procedure Visit_Body

(Self : Print; Dest : Bodies.Body_Record'Class)

is

begin

IO.Put_Line ("Visiting Body");

end Visit_Body;

procedure Visit_Car (Self : Visitor; Dest : Cars.Car_Record'Class) is

begin

Self.Visit_Car (Dest);

end Visit_Car;

overriding procedure Visit_Car

(Self : Perform; Dest : Cars.Car_Record'Class)

is

begin

IO.Put_Line ("Starting my car");

end Visit_Car;

overriding procedure Visit_Car (Self : Print; Dest : Cars.Car_Record'Class)

is

begin

IO.Put_Line ("Visiting Car");

end Visit_Car;

procedure Visit_Engine (Self : Visitor; Dest : Engines.Engine_Record'Class)

is

begin

Self.Visit_Engine (Dest);

end Visit_Engine;

overriding procedure Visit_Engine

(Self : Perform; Dest : Engines.Engine_Record'Class)

is

begin

IO.Put_Line ("Revving my Engine");

end Visit_Engine;

overriding procedure Visit_Engine

(Self : Print; Dest : Engines.Engine_Record'Class)

is

begin

IO.Put_Line ("Visiting Engine");

end Visit_Engine;

procedure Visit_Wheel (Self : Visitor; Dest : Wheels.Wheel_Record'Class) is

begin

Self.Visit_Wheel (Dest);

end Visit_Wheel;

overriding procedure Visit_Wheel

(Self : Perform; Dest : Wheels.Wheel_Record'Class)

is

begin

IO.Put_Line ("Rolling my " & To_String (Dest.Name) & " wheel");

end Visit_Wheel;

overriding procedure Visit_Wheel

(Self : Print; Dest : Wheels.Wheel_Record'Class)

is

begin

IO.Put_Line ("Visiting " & To_String (Dest.Name) & " wheel");

end Visit_Wheel;

end Visitors;

</syntaxhighlight>

<syntaxhighlight lang="ada">pragma Ada_2022;

with Base;

limited with Visitors;

package Bodies is

type Body_Record is new Base.Base_Record with private;

procedure Visit (Self : Body_Record; Visitor : Visitors.Visitor'Class);

private

type Body_Record is new Base.Base_Record with null record;

end Bodies;

</syntaxhighlight>

<syntaxhighlight lang="ada">pragma Ada_2022;

with Visitors;

package body Bodies is

procedure Visit (Self : Body_Record; Visitor : Visitors.Visitor'Class) is

begin

Visitor.Visit_Body (Self);

end Visit;

end Bodies;

</syntaxhighlight>

<syntaxhighlight lang="ada">pragma Ada_2022;

with Base;

with Bodies;

with Engines;

with Wheels;

limited with Visitors;

package Cars is

type Car_Record is new Base.Base_Record with private;

procedure Visit (Self : Car_Record; Visitor : Visitors.Visitor'Class);

function Initialize return Car_Record;

private

type Wheel_Array is array (1 .. 4) of Wheels.Wheel_Record;

type Car_Record is new Base.Base_Record with record

Bod : Bodies.Body_Record;

Eng : Engines.Engine_Record;

Whs : Wheel_Array;

end record;

end Cars;

</syntaxhighlight>

<syntaxhighlight lang="ada">pragma Ada_2022;

with Ada.Strings.Unbounded;

with Visitors;

package body Cars is

subtype Unbounded_String is Ada.Strings.Unbounded.Unbounded_String;

use all type Unbounded_String;

procedure Visit (Self : Car_Record; Visitor : Visitors.Visitor'Class) is

begin

Visitor.Visit_Car (Self);

Visitor.Visit_Body (Self.Bod);

Visitor.Visit_Engine (Self.Eng);

for Wheel of Self.Whs loop

Visitor.Visit_Wheel (Wheel);

end loop;

end Visit;

function Initialize return Car_Record is

Result : Car_Record;

begin

Result.Whs :=

[Wheels.Initialize (To_Unbounded_String ("front left")),

Wheels.Initialize (To_Unbounded_String ("front right")),

Wheels.Initialize (To_Unbounded_String ("back left")),

Wheels.Initialize (To_Unbounded_String ("back right"))];

return Result;

end Initialize;

end Cars;

</syntaxhighlight>

<syntaxhighlight lang="ada">pragma Ada_2022;

with Base;

limited with Visitors;

package Engines is

type Engine_Record is new Base.Base_Record with private;

procedure Visit (Self : Engine_Record; Visitor : Visitors.Visitor'Class);

private

type Engine_Record is new Base.Base_Record with null record;

end Engines;

</syntaxhighlight>

<syntaxhighlight lang="ada">pragma Ada_2022;

with Visitors;

package body Engines is

procedure Visit (Self : Engine_Record; Visitor : Visitors.Visitor'Class) is

begin

Visitor.Visit_Engine (Self);

end Visit;

end Engines;

</syntaxhighlight>

<syntaxhighlight lang="ada">pragma Ada_2022;

with Ada.Strings.Unbounded;

with Base;

limited with Visitors;

package Wheels is

subtype Unbounded_String is Ada.Strings.Unbounded.Unbounded_String;

use all type Unbounded_String;

type Wheel_Record is new Base.Base_Record with private;

procedure Visit (Self : Wheel_Record; Visitor : Visitors.Visitor'Class);

function Initialize (Name : Unbounded_String) return Wheel_Record;

function Name (Me : Wheel_Record) return Unbounded_String;

private

type Wheel_Record is new Base.Base_Record with record

My_Name : Unbounded_String;

end record;

end Wheels;

</syntaxhighlight>

<syntaxhighlight lang="ada">pragma Ada_2022;

with Visitors;

package body Wheels is

procedure Visit (Self : Wheel_Record; Visitor : Visitors.Visitor'Class) is

begin

Visitor.Visit_Wheel (Self);

end Visit;

function Initialize (Name : Unbounded_String) return Wheel_Record is

(My_Name => Name);

function Name (Me : Wheel_Record) return Unbounded_String is (Me.My_Name);

end Wheels;

</syntaxhighlight>

<syntaxhighlight lang="ada">pragma Ada_2022;

with Cars;

with Visitors;

procedure Visitor_Pattern is

Car : Cars.Car_Record := Cars.Initialize;

Performer : aliased Visitors.Perform;

Printer : aliased Visitors.Print;

begin

Car.Visit (Performer);

Car.Visit (Printer);

end Visitor_Pattern;

</syntaxhighlight>

===Method 2: Discriminated Types===