MycLib/Src/Data/Myc.Data.Types.Method.pas

unit Myc.Data.Types.Method;

interface

uses
    System.SysUtils,
    System.Generics.Collections,
    Myc.Data.Types;

type
    // Implements the IDataMethodType interface.
    TImplDataMethodType = class(TInterfacedObject, IDataMethodType)
    strict private
        // Class-level registry to cache and reuse method type definitions.
        class var
            FMethodTypeRegistry: TDictionary<TPair<IDataType, IDataType>, IDataMethodType>;
    private
        FArgType: IDataType;
        FResultType: IDataType;
        function GetName: String;
        function GetKind: TDataKind;
        function GetArgType: IDataType;
        function GetResultType: IDataType;
        function CreateValue(const AValue: TDataMethodProc): IDataMethodValue;
    public
        constructor Create(const AArgType, AResultType: IDataType);

        class constructor CreateClass;
        class destructor DestroyClass;
        // Factory method to get a cached or new method type instance.
        class function GetInstance(const AArgType, AResultType: IDataType): IDataMethodType; static;
    end;

implementation

uses
    System.Classes,
    System.SyncObjs,
    System.Generics.Defaults;

type
    // Implements the IDataMethodValue interface.
    TImplDataMethodValue = class(TInterfacedObject, IDataMethodValue)
    private
        FDataType: IDataMethodType;
        FValue: TDataMethodProc;
        function GetDataType: IDataType;
        function GetAsString: string;
        function GetValue: TDataMethodProc;
    public
        constructor Create(const ADataType: IDataMethodType; const AValue: TDataMethodProc);
    end;

{ TImplDataMethodType }

class constructor TImplDataMethodType.CreateClass;
begin
    // Initialize the global registry for method types using a custom comparer for the TPair key.
    FMethodTypeRegistry :=
        TDictionary<TPair<IDataType, IDataType>, IDataMethodType>.Create(
            TEqualityComparer<TPair<IDataType, IDataType>>.Construct(
                function(const Left, Right: TPair<IDataType, IDataType>): Boolean
                begin
                    // Compare interface pointers.
                    Result := (Left.Key = Right.Key) and (Left.Value = Right.Value);
                end,
                function(const Value: TPair<IDataType, IDataType>): Integer
                var
                    hash1, hash2: NativeInt;
                begin
                    // Combine hashes of interface pointers.
                    hash1 := NativeInt(Value.Key);
                    hash2 := NativeInt(Value.Value);
                    Result := Integer(hash1 xor hash2);
                end
            )
        );
end;

class destructor TImplDataMethodType.DestroyClass;
begin
    FMethodTypeRegistry.Free;
    FMethodTypeRegistry := nil;
end;

class function TImplDataMethodType.GetInstance(const AArgType, AResultType: IDataType): IDataMethodType;
var
    key: TPair<IDataType, IDataType>;
    res: IDataMethodType;
begin
    key := TPair<IDataType, IDataType>.Create(AArgType, AResultType);
    TMonitor.Enter(FMethodTypeRegistry);
    try
        if not FMethodTypeRegistry.TryGetValue(key, res) then
        begin
            res := TImplDataMethodType.Create(AArgType, AResultType);
            FMethodTypeRegistry.Add(key, res);
        end;
    finally
        TMonitor.Exit(FMethodTypeRegistry);
    end;
    Result := res;
end;

constructor TImplDataMethodType.Create(const AArgType, AResultType: IDataType);
begin
    inherited Create;
    FArgType := AArgType;
    FResultType := AResultType;
end;

function TImplDataMethodType.CreateValue(const AValue: TDataMethodProc): IDataMethodValue;
begin
    Assert(Assigned(AValue));

    Result := TImplDataMethodValue.Create(Self, AValue);
end;

function TImplDataMethodType.GetArgType: IDataType;
begin
    Result := FArgType;
end;

function TImplDataMethodType.GetResultType: IDataType;
begin
    Result := FResultType;
end;

function TImplDataMethodType.GetKind: TDataKind;
begin
    Result := dkMethod;
end;

function TImplDataMethodType.GetName: String;
var
    sb: TStringBuilder;
    argName, resultName: string;
begin
    if Assigned(FArgType) then
        argName := FArgType.Name
    else
        argName := 'Void';

    if Assigned(FResultType) then
        resultName := FResultType.Name
    else
        resultName := 'Void';

    sb := TStringBuilder.Create;
    try
        sb.Append('Method<');
        sb.Append(argName);
        sb.Append(' -> ');
        sb.Append(resultName);
        sb.Append('>');
        Result := sb.ToString;
    finally
        sb.Free;
    end;
end;

{ TImplDataMethodValue }

constructor TImplDataMethodValue.Create(const ADataType: IDataMethodType; const AValue: TDataMethodProc);
begin
    inherited Create;
    FDataType := ADataType;
    FValue := AValue;
end;

function TImplDataMethodValue.GetDataType: IDataType;
begin
    Result := FDataType;
end;

function TImplDataMethodValue.GetAsString: string;
begin
    Result := '<METHOD>';
end;

function TImplDataMethodValue.GetValue: TDataMethodProc;
begin
    Result := FValue;
end;

end.