From c0fd594008b6161ac31f7fb058f1b48f0ccc9eb6 Mon Sep 17 00:00:00 2001 From: Michael Schimmel Date: Mon, 25 Aug 2025 19:27:13 +0200 Subject: [PATCH] Indicator with new types --- Src/Data/Myc.Data.Types.pas | 103 ++++++++++++++++++++++++++++----- Src/Data/TestDataTypes.pas | 110 +++++++++++++++++++++++++++++------- Test/MycTests.dpr | 3 +- Test/MycTests.dproj | 1 + 4 files changed, 183 insertions(+), 34 deletions(-) diff --git a/Src/Data/Myc.Data.Types.pas b/Src/Data/Myc.Data.Types.pas index ba4d95b..ca2952a 100644 --- a/Src/Data/Myc.Data.Types.pas +++ b/Src/Data/Myc.Data.Types.pas @@ -8,7 +8,7 @@ uses System.RTTI; type - TDataKind = (dkOrdinal, dkFloat, dkText, dkTimestamp, dkRecord, dkTuple, dkArray, dkEnum); + TDataKind = (dkOrdinal, dkFloat, dkText, dkTimestamp, dkRecord, dkTuple, dkArray, dkEnum, dkMethod); IDataType = interface function GetName: String; @@ -76,6 +76,28 @@ type property Identifiers[Idx: Integer]: string read GetIdentifier; default; end; + // A method that transforms one data value into another. + TMethodProc = reference to function(const AValue: IDataValue): IDataValue; + + // Represents an executable method data value. + IDataMethodValue = interface(IDataValue) + {$region 'private'} + function GetValue: TMethodProc; + {$endregion} + property Value: TMethodProc read GetValue; + end; + + // Represents the type of a method data value, including its signature. + IDataMethodType = interface(IDataType) + {$region 'private'} + function GetArgType: IDataType; + function GetResultType: IDataType; + {$endregion} + property ArgType: IDataType read GetArgType; + property ResultType: IDataType read GetResultType; + function CreateValue(const AValue: TMethodProc): IDataMethodValue; + end; + IDataRecordValue = interface(IDataValue) function GetItem(Idx: Integer): IDataValue; property Items[Idx: Integer]: IDataValue read GetItem; default; @@ -125,18 +147,15 @@ type FDataType: IDataType; function GetName: String; inline; function GetKind: TDataKind; inline; - class var FArrayTypeRegistry: TDictionary; - class var FRecordTypeRegistry: TDictionary, IDataRecordType>; + FMethodTypeRegistry: TDictionary, IDataMethodType>; class constructor CreateClass; class destructor DestroyClass; public constructor Create(const ADataType: IDataType); - class procedure ClearRegistries; static; - class operator Implicit(const A: IDataType): TDataType; overload; class operator Implicit(const A: TDataType): IDataType; overload; @@ -146,7 +165,8 @@ type class function Text: IDataTextType; static; class function Timestamp: IDataTimestampType; static; class function Tuple: IDataTupleType; static; - class function ArrayOfType(const AElementType: IDataType): IDataArrayType; static; + class function MethodOf(const AArgType, AResultType: IDataType): IDataMethodType; static; + class function ArrayOf(const AElementType: IDataType): IDataArrayType; static; class function RecordOf(const Fields: TArray): IDataRecordType; overload; static; class function RecordOf(const Fields: array of TRecordField): IDataRecordType; overload; static; class function EnumOf(const AName: string; const AIdentifiers: array of string): IDataEnumType; static; @@ -160,6 +180,7 @@ type function AsTuple: IDataTupleType; function AsArray: IDataArrayType; function AsEnum: IDataEnumType; + function AsMethod: IDataMethodType; property DataType: IDataType read FDataType; property Name: String read GetName; @@ -182,6 +203,7 @@ type function AsTuple: IDataTupleValue; function AsArray: IDataArrayValue; function AsEnum: IDataEnumValue; + function AsMethod: IDataMethodValue; class operator Implicit(const A: IDataValue): TDataValue; overload; class operator Implicit(const A: TDataValue): IDataValue; overload; @@ -192,6 +214,7 @@ type class function FromText(const AValue: string): IDataTextValue; static; class function FromTimestamp(const AValue: TDateTime): IDataTimestampValue; static; class function FromTuple(const AItems: array of IDataValue): IDataTupleValue; static; + class function FromMethod(const AMethodType: IDataMethodType; const AValue: TMethodProc): IDataMethodValue; static; property DataValue: IDataValue read FDataValue; property DataType: IDataType read GetDataType; @@ -209,7 +232,8 @@ uses Myc.Data.Types.Arrays, Myc.Data.Types.Records, Myc.Data.Types.Tuple, - Myc.Data.Types.Enum; + Myc.Data.Types.Enum, + Myc.Data.Types.Method; { TRecordField } @@ -230,15 +254,34 @@ class constructor TDataType.CreateClass; begin FArrayTypeRegistry := TDictionary.Create; FRecordTypeRegistry := TDictionary, IDataRecordType>.Create(TRecordFieldComparer.Create); + FMethodTypeRegistry := + TDictionary, IDataMethodType>.Create( + TEqualityComparer>.Construct( + function(const Left, Right: TPair): Boolean + begin + Result := (Left.Key = Right.Key) and (Left.Value = Right.Value); + end, + function(const Value: TPair): Integer + var + hash1, hash2: NativeInt; + begin + hash1 := NativeInt(Value.Key); + hash2 := NativeInt(Value.Value); + // Simple XOR combination for pointer hashes + Result := Integer(hash1 xor hash2); + end + ) + ); end; class destructor TDataType.DestroyClass; begin FArrayTypeRegistry.Free; FRecordTypeRegistry.Free; + FMethodTypeRegistry.Free; end; -class function TDataType.ArrayOfType(const AElementType: IDataType): IDataArrayType; +class function TDataType.ArrayOf(const AElementType: IDataType): IDataArrayType; begin if not Assigned(AElementType) then raise EArgumentException.Create('Cannot create an array type with a nil element type.'); @@ -277,6 +320,13 @@ begin Result := IDataFloatType(FDataType); end; +function TDataType.AsMethod: IDataMethodType; +begin + if (FDataType.Kind <> dkMethod) then + raise EInvalidCast.Create('Method expected'); + Result := IDataMethodType(FDataType); +end; + function TDataType.AsOrdinal: IDataOrdinalType; begin if (FDataType.Kind <> dkOrdinal) then @@ -312,12 +362,6 @@ begin Result := IDataTupleType(FDataType); end; -class procedure TDataType.ClearRegistries; -begin - FArrayTypeRegistry.Clear; - FRecordTypeRegistry.Clear; -end; - class function TDataType.Float: IDataFloatType; begin Result := TDataFloatType.Singleton; @@ -331,6 +375,23 @@ begin Result := ''; end; +class function TDataType.MethodOf(const AArgType, AResultType: IDataType): IDataMethodType; +var + key: TPair; +begin + key := TPair.Create(AArgType, AResultType); + TMonitor.Enter(FMethodTypeRegistry); + try + if not FMethodTypeRegistry.TryGetValue(key, Result) then + begin + Result := TDataMethodType.Create(AArgType, AResultType); + FMethodTypeRegistry.Add(key, Result); + end; + finally + TMonitor.Exit(FMethodTypeRegistry); + end; +end; + class function TDataType.Ordinal: IDataOrdinalType; begin Result := TDataOrdinalType.Singleton; @@ -417,6 +478,13 @@ begin Result := IDataFloatValue(FDataValue); end; +function TDataValue.AsMethod: IDataMethodValue; +begin + if FDataValue.DataType.Kind <> dkMethod then + raise EInvalidCast.Create('Method expected'); + Result := IDataMethodValue(FDataValue); +end; + function TDataValue.AsText: IDataTextValue; begin if FDataValue.DataType.Kind <> dkText then @@ -469,6 +537,13 @@ begin Result := TDataFloatType.Singleton.CreateValue(AValue); end; +class function TDataValue.FromMethod(const AMethodType: IDataMethodType; const AValue: TMethodProc): IDataMethodValue; +begin + if not Assigned(AMethodType) then + raise EArgumentException.Create('AMethodType'); + Result := AMethodType.CreateValue(AValue); +end; + class function TDataValue.FromText(const AValue: string): IDataTextValue; begin Result := TDataTextType.Singleton.CreateValue(AValue); diff --git a/Src/Data/TestDataTypes.pas b/Src/Data/TestDataTypes.pas index e51ae90..9bc8357 100644 --- a/Src/Data/TestDataTypes.pas +++ b/Src/Data/TestDataTypes.pas @@ -10,9 +10,6 @@ type [IgnoreMemoryLeaks] TMyTestObject = class public - [TestFixtureTearDown] - procedure FixtureTearDown; - [Test] procedure TestRecords; [Test] @@ -39,6 +36,8 @@ type procedure TestAsString; [Test] procedure TestAsTValue; + [Test] + procedure TestMethods; end; implementation @@ -50,15 +49,6 @@ uses System.TypInfo, Myc.Data.Types; -{ TMyTestObject } - -procedure TMyTestObject.FixtureTearDown; -begin - // Clear global type caches to release any interfaces created during tests. - // This prevents access violations on shutdown from dangling pointers in the registries. - TDataType.ClearRegistries; -end; - procedure TMyTestObject.TestRecords; var intType: IDataType; @@ -236,18 +226,18 @@ begin floatType := TDataType.Float; // --- 2. Test Type Creation and Caching --- - intArrayType1 := TDataType.ArrayOfType(intType); + intArrayType1 := TDataType.ArrayOf(intType); Assert.IsNotNull(intArrayType1, 'ArrayType should be created'); Assert.AreSame(intType, intArrayType1.ElementType, 'ElementType should be Integer'); Assert.AreEqual('Array', intArrayType1.Name, 'Type name should be Array'); // Test caching - intArrayType2 := TDataType.ArrayOfType(intType); + intArrayType2 := TDataType.ArrayOf(intType); Assert.AreSame(intArrayType1, intArrayType2, 'Array types should be cached'); // Test uniqueness - floatArrayType := TDataType.ArrayOfType(floatType); + floatArrayType := TDataType.ArrayOf(floatType); Assert.AreNotSame(intArrayType1, floatArrayType, 'Different element types should result in different array types'); Assert.AreEqual('Array', floatArrayType.Name, 'Type name should be Array'); @@ -265,7 +255,7 @@ begin // --- 4. Test Validation and Error Handling --- // Test creating an array with a nil element type - Assert.WillRaise(procedure begin TDataType.ArrayOfType(nil); end, EArgumentException, 'Nil element type should raise an exception'); + Assert.WillRaise(procedure begin TDataType.ArrayOf(nil); end, EArgumentException, 'Nil element type should raise an exception'); // Test creating a value with an incorrect element type (homogeneity check) Assert.WillRaise( @@ -284,7 +274,7 @@ var arrayType: IDataArrayType; empty1, empty2, single, generic: IDataArrayValue; begin - arrayType := TDataType.ArrayOfType(TDataType.Ordinal); + arrayType := TDataType.ArrayOf(TDataType.Ordinal); // Test optimized path for 0 elements (cached singleton per type) empty1 := arrayType.CreateValue([]); @@ -515,7 +505,7 @@ begin Assert.AreEqual('Green', enumValue.AsString, 'Enum AsString incorrect'); // Array - intArrayType := TDataType.ArrayOfType(TDataType.Ordinal); + intArrayType := TDataType.ArrayOf(TDataType.Ordinal); arrayValue := intArrayType.CreateValue([TDataValue.FromOrdinal(1), TDataValue.FromOrdinal(2)]); Assert.AreEqual('[1, 2]', arrayValue.AsString, 'Array AsString incorrect'); @@ -576,7 +566,7 @@ begin Assert.AreEqual(1, tv.AsInteger, 'Enum TValue content is incorrect'); // --- Array --- - intArrayType := TDataType.ArrayOfType(TDataType.Ordinal); + intArrayType := TDataType.ArrayOf(TDataType.Ordinal); dataValue := intArrayType.CreateValue([TDataValue.FromOrdinal(10), TDataValue.FromOrdinal(20)]); tv := dataValue.AsTValue; Assert.IsFalse(tv.IsEmpty, 'Array TValue should not be empty'); @@ -620,4 +610,86 @@ begin Assert.AreEqual('Red', tv.GetArrayElement(1).AsType.AsString, 'Tuple TValue element 1 is incorrect'); end; +procedure TMyTestObject.TestMethods; +var + ordinalType, textType: IDataType; + methodType1, methodType2, otherMethodType: IDataMethodType; + myFunc: TMethodProc; + methodValue: IDataMethodValue; + inputValue, resultValue: IDataValue; + tv: TValue; +begin + // --- 1. Setup: Define base types --- + ordinalType := TDataType.Ordinal; + textType := TDataType.Text; + + // --- 2. Test Type Creation and Caching --- + methodType1 := TDataType.MethodOf(ordinalType, textType); + + // Assertions for the created type + Assert.IsNotNull(methodType1, 'MethodType should be created'); + Assert.AreEqual(dkMethod, methodType1.Kind, 'Kind should be dkMethod'); + Assert.AreSame(ordinalType, methodType1.ArgType, 'ArgType should be Ordinal'); + Assert.AreSame(textType, methodType1.ResultType, 'ResultType should be Text'); + Assert.AreEqual('Method Text>', methodType1.Name, 'Type name should match expected format'); + + // Test if the same definition returns the same cached instance + methodType2 := TDataType.MethodOf(ordinalType, textType); + Assert.AreSame(methodType1, methodType2, 'Method types should be cached and return the same instance'); + + // Test if a different definition returns a new instance + otherMethodType := TDataType.MethodOf(textType, ordinalType); + Assert.AreNotSame(methodType1, otherMethodType, 'Different signatures should result in different types'); + Assert.AreEqual('Method Integer>', otherMethodType.Name, 'Name of other method type is incorrect'); + + // --- 3. Test Value Creation --- + // Define a function that matches the signature Ordinal -> Text + myFunc := + function(const AValue: IDataValue): IDataValue + var + ordinalValue: IDataOrdinalValue; + val: Int64; + begin + ordinalValue := TDataValue(AValue).AsOrdinal; + val := ordinalValue.Value; + Result := TDataValue.FromText(val.ToString); + end; + + methodValue := TDataValue.FromMethod(methodType1, myFunc); + Assert.IsNotNull(methodValue, 'MethodValue should be created'); + Assert.AreSame(methodType1, methodValue.DataType, 'Value should have the correct data type'); + + // --- 4. Test Execution (Simulated) --- + inputValue := TDataValue.FromOrdinal(42); + // Execute the function retrieved from the value + resultValue := methodValue.Value(inputValue); + + Assert.IsNotNull(resultValue, 'Execution result should not be nil'); + Assert.AreSame(textType, resultValue.DataType, 'Result value should have Text type'); + Assert.AreEqual('42', TDataValue(resultValue).AsText.Value, 'Result value content is incorrect'); + + // --- 5. Test AsString and AsTValue --- + Assert.AreEqual('', methodValue.AsString, 'Method AsString is incorrect'); + + tv := methodValue.AsTValue; + Assert.IsFalse(tv.IsEmpty, 'Method TValue should not be empty'); + Assert.AreEqual(tkInterface, tv.Kind, 'TValue kind for a TMethodProc should be tkInterface, as it is a reference-to-function'); + Assert.IsTrue(TypeInfo(TMethodProc) = tv.TypeInfo, 'TValue should hold TMethodProc type info'); + + // --- 6. Test Validation and Error Handling --- + // Test creating a value with a nil type + Assert.WillRaise( + procedure begin TDataValue.FromMethod(nil, myFunc); end, + EArgumentException, + 'FromMethod with nil type should raise an exception' + ); + + // Test creating a value with a nil function + Assert.WillRaise( + procedure begin TDataValue.FromMethod(methodType1, nil); end, + EArgumentException, + 'FromMethod with nil function should raise an exception' + ); +end; + end. diff --git a/Test/MycTests.dpr b/Test/MycTests.dpr index 883c047..8a91e3a 100644 --- a/Test/MycTests.dpr +++ b/Test/MycTests.dpr @@ -31,7 +31,8 @@ uses Myc.Data.Types.Records in 'Myc.Data.Types.Records.pas', Myc.Data.Types.Float in 'Myc.Data.Types.Float.pas', Myc.Data.Types.Arrays in 'Myc.Data.Types.Arrays.pas', - TestDataTypes in '..\Src\Data\TestDataTypes.pas'; + TestDataTypes in '..\Src\Data\TestDataTypes.pas', + Myc.Data.Types.Method in '..\Src\Data\Myc.Data.Types.Method.pas'; { keep comment here to protect the following conditional from being removed by the IDE when adding a unit } {$IFNDEF TESTINSIGHT} diff --git a/Test/MycTests.dproj b/Test/MycTests.dproj index 0ef366c..9df8acd 100644 --- a/Test/MycTests.dproj +++ b/Test/MycTests.dproj @@ -133,6 +133,7 @@ $(PreBuildEvent)]]> + Base