Brummel/MycLib
1
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects 1 Releases Wiki Activity

Generic indicator factory

Browse Source
This commit is contained in:
Michael Schimmel
2025-07-27 11:42:27 +02:00
parent 468adcf203
commit 86001b654f
2 changed files with 286 additions and 115 deletions
Download Patch File Download Diff File Expand all files Collapse all files
AuraTrader/TestMethodCallFromRecordParams.pas
+169 -64
View File
@@ -13,20 +13,36 @@ uses
Myc.Data.Records;
type
InvokeAttribute = class(TCustomAttribute);
FactoryAttribute = class(TCustomAttribute);
TIndicatorProc<TValue, TResult> = reference to function(const Value: TValue): TResult;
TIndicatorFactoryProc<TParams, TValue, TResult> = reference to function(const Params: TParams): TIndicatorProc<TValue, TResult>;
TMyProc<TValue, TResult> = reference to function(const [ref] Value: TValue): TResult;
TFactoryProc<TParams, TValue, TResult> = reference to function(const [ref] Params: TParams): TMyProc<TValue, TResult>;
IndicatorFactoryAttribute = class(TCustomAttribute);
TMyWorker = record
TGenericIndicatorFactory = class
private
FParameterLayout: TDataRecord.TLayout;
FFactoryProc: TIndicatorFactoryProc<TDataRecord, TDataRecord, TDataRecord>;
public
constructor Create(
const AParameterLayout: TDataRecord.TLayout;
const AFactoryProc: TIndicatorFactoryProc<TDataRecord, TDataRecord, TDataRecord>
);
class function CreateFromTemplate<T>: TGenericIndicatorFactory;
function CreateIndicator(const Params: TDataRecord): TIndicatorProc<TDataRecord, TDataRecord>;
property ParameterLayout: TDataRecord.TLayout read FParameterLayout;
end;
TMyWorker = class
published
type
TParams = record
Log: Int64;
text: String;
end;
TValue = record
TArgs = record
xyz: Double;
end;
@@ -35,98 +51,187 @@ type
desc: String;
end;
[Factory]
class function CreateFactory: TFactoryProc<TParams, TValue, TResult>; static;
[IndicatorFactory]
class function CreateFactory: TIndicatorFactoryProc<TParams, TArgs, TResult>; static;
end;
procedure Test1(const Log: TStrings);
implementation
class function TMyWorker.CreateFactory: TFactoryProc<TParams, TValue, TResult>;
class function TMyWorker.CreateFactory: TIndicatorFactoryProc<TParams, TArgs, TResult>;
begin
Result :=
function(const [ref] Params: TParams): TMyProc<TValue, TResult>
function(const Params: TParams): TIndicatorProc<TArgs, TResult>
begin
var Log := TStrings(Params.Log);
var text := Params.text;
Result :=
function(const [ref] Value: TValue): TResult
function(const Args: TArgs): TResult
begin
// Use Format to avoid locale issues with float conversion
Log.Add(Format('Val=%f (...%s)', [Value.xyz, text]));
Log.Add(Format('Val=%f (...%s)', [Args.xyz, text]));
Result.desc := 'done';
end;
end;
end;
type
TInvokeProc = reference to procedure(const Value, Res: TDataRecord);
function CreateInvoker(Ctx: TRttiContext; CallFunc: TValue): TInvokeProc;
constructor TGenericIndicatorFactory.Create(
const AParameterLayout: TDataRecord.TLayout;
const AFactoryProc: TIndicatorFactoryProc<TDataRecord, TDataRecord, TDataRecord>
);
begin
var rttiMyProc := Ctx.GetType(CallFunc.TypeInfo);
var workerInvokeMethod := rttiMyProc.GetMethod('Invoke');
var workerParamTypeInfo := workerInvokeMethod.GetParameters[0].ParamType.Handle;
var args: array[0..0] of TValue;
Result :=
procedure(const Value, Res: TDataRecord)
inherited Create;
FParameterLayout := AParameterLayout;
FFactoryProc := AFactoryProc;
end;
class function TGenericIndicatorFactory.CreateFromTemplate<T>: TGenericIndicatorFactory;
var
Ctx: TRttiContext;
rttiType: TRttiType;
templateFactoryMethod: TRttiMethod;
parameterLayout: TDataRecord.TLayout;
factoryProc: TIndicatorFactoryProc<TDataRecord, TDataRecord, TDataRecord>;
begin
// This function creates a generic factory from a template class (like TMyWorker).
// It uses RTTI to find the necessary types (TParams, TValue, TResult) and the
// factory method, and then constructs a set of wrappers to adapt the specific
// types of the template to the generic TDataRecord used by this factory.
Ctx := TRttiContext.Create;
rttiType := Ctx.GetType(TypeInfo(T));
// Find nested record types for parameters, values, and results.
var paramsType := Ctx.FindType(rttiType.QualifiedName + '.' + 'TParams');
if not Assigned(paramsType) then
raise EArgumentException.CreateFmt('TParams not found in "%s"', [rttiType.Name]);
var argsType := Ctx.FindType(rttiType.QualifiedName + '.' + 'TArgs');
if not Assigned(paramsType) then
raise EArgumentException.CreateFmt('TArgs not found in "%s"', [rttiType.Name]);
var resultType := Ctx.FindType(rttiType.QualifiedName + '.' + 'TResult');
if not Assigned(paramsType) then
raise EArgumentException.CreateFmt('TResult not found in "%s"', [rttiType.Name]);
// Find the static factory method marked with the [Factory] attribute.
templateFactoryMethod := nil;
for var method in rttiType.GetMethods do
begin
if method.HasAttribute<IndicatorFactoryAttribute> then
begin
TValue.MakeWithoutCopy(Value.RawData, workerParamTypeInfo, args[0], true);
workerInvokeMethod.Invoke(CallFunc, args).ExtractRawData(Res.RawData);
templateFactoryMethod := method;
break;
end;
end;
if not Assigned(templateFactoryMethod) then
raise EArgumentException.CreateFmt('[Factory] attribute not found on any method in "%s"', [rttiType.Name]);
// Create the layout for the parameters, which will be exposed by this factory.
parameterLayout := TDataRecord.TLayout.FromRecord(paramsType.Handle);
// Create the main factory procedure. This is a double-nested anonymous method
// that wraps the template's specific factory and worker functions.
factoryProc :=
function(const Params: TDataRecord): TIndicatorProc<TDataRecord, TDataRecord>
var
// Capture the created worker proc from the original factory as a TValue to manage its lifetime.
workerProcAsValue: TValue;
begin
// Outer anonymous method: This is the factory proc.
// It gets called with a TDataRecord of parameters.
// 1. Invoke the template's static factory method (e.g., TMyWorker.CreateFactory)
var factoryProcAsValue := templateFactoryMethod.Invoke(TValue.Empty, []);
// 2. Invoke the factory proc itself to get the actual worker proc.
var rttiFactoryProc := Ctx.GetType(factoryProcAsValue.TypeInfo) as TRttiInterfaceType;
var factoryInvokeMethod := rttiFactoryProc.GetMethod('Invoke');
// The parameter for this 'Invoke' call is the TParams record.
// Wrap the incoming TDataRecord 'Params' into a TValue for the call.
var factoryParamTypeInfo := factoryInvokeMethod.GetParameters[0].ParamType.Handle;
Assert(factoryParamTypeInfo = paramsType.Handle);
var factoryArg: array[0..0] of TValue;
TValue.Make(Params.RawData, factoryParamTypeInfo, factoryArg[0]);
// This call returns the worker proc (e.g., a TIndicatorProc<TValue, TResult>) as a TValue.
workerProcAsValue := factoryInvokeMethod.Invoke(factoryProcAsValue, factoryArg);
// 3. Return a new anonymous method that wraps the worker proc.
// This wrapper conforms to the generic TIndicatorProc<TDataRecord, TDataRecord> signature.
var rttiWorkerProc := Ctx.GetType(workerProcAsValue.TypeInfo);
var indicatorInvokeMethod := rttiWorkerProc.GetMethod('Invoke');
var indicatorParamTypeInfo := indicatorInvokeMethod.GetParameters[0].ParamType.Handle;
var indicatorResultTypeInfo := indicatorInvokeMethod.ReturnType.Handle;
Assert(indicatorParamTypeInfo = argsType.Handle);
Assert(indicatorResultTypeInfo = resultType.Handle);
var valueLayout := TDataRecord.TLayout.FromRecord(indicatorParamTypeInfo);
var resultLayout := TDataRecord.TLayout.FromRecord(indicatorResultTypeInfo);
Result :=
function(const Value: TDataRecord): TDataRecord
begin
// Inner anonymous method: This is the actual indicator proc wrapper.
Assert(Value.Layout = valueLayout);
// Prepare argument for the worker proc invocation.
var args: array[0..0] of TValue;
TValue.MakeWithoutCopy(Value.RawData, indicatorParamTypeInfo, args[0], true);
// Invoke the actual worker proc.
var resultAsTValue := indicatorInvokeMethod.Invoke(workerProcAsValue, args);
// The result is a TValue containing the result record (e.g., TMyWorker.TResult).
// Copy its contents into a new TDataRecord to return it.
Assert(TDataRecord.TLayout.FromRecord(resultAsTValue.TypeInfo) = resultLayout);
Result := TDataRecord.Create(resultLayout);
var src := resultAsTValue.GetReferenceToRawData;
resultLayout.Copy(src, Result.RawData);
// Erase all raw data in the TValue, leaving it as an empty capsule. Ownership it taken
// over to the resulting TDataRecord.
FillChar(src^, resultLayout.Size, 0);
end;
end;
// Create the final factory instance with the generated layout and wrapper procedure.
Result := TGenericIndicatorFactory.Create(parameterLayout, factoryProc);
end;
function TGenericIndicatorFactory.CreateIndicator(const Params: TDataRecord): TIndicatorProc<TDataRecord, TDataRecord>;
begin
// The factory proc does all the heavy lifting. We just need to call it.
// A real implementation might add checks, e.g., that the layout of Params matches.
Assert(
(not Assigned(FParameterLayout.Fields)) or (Params.Layout = FParameterLayout),
'Invalid parameter layout for indicator creation'
);
Result := FFactoryProc(Params);
end;
procedure Test1(const Log: TStrings);
begin
var fact := TGenericIndicatorFactory.CreateFromTemplate<TMyWorker>;
var params := TDataRecord.FromRecord<TMyWorker.TParams>;
params.SetValue<Int64>('Log', Int64(Log));
params.SetValue<String>('text', 'The quick brown fox jumps...');
var workerValueParam := TDataRecord.FromRecord<TMyWorker.TValue>;
workerValueParam.SetValue<Double>('xyz', 3.14159);
var indi := fact.CreateIndicator(params);
var finalResultRec := TDataRecord.FromRecord<TMyWorker.TResult>;
var args := TDataRecord.FromRecord<TMyWorker.TArgs>;
args.SetValue<Double>('xyz', 3.14159);
var invoke: TInvokeProc;
var res := indi(args);
////////////
var Ctx := TRttiContext.Create;
var rttiType := Ctx.GetType(TypeInfo(TMyWorker));
// Find and invoke the method marked with [Factory] attribute.
for var method in rttiType.GetMethods do
begin
if method.HasAttribute<FactoryAttribute> then
begin
// First invocation returns the factory procedure itself (an interface).
var createFuncValue := method.Invoke(TValue.Empty, []);
// Anonymous methods are interfaces, so we get the TRttiInterfaceType.
var rttiCreateFunc := Ctx.GetType(createFuncValue.TypeInfo) as TRttiInterfaceType;
// The actual code is in the 'Invoke' method of that interface.
var factoryInvokeMethod := rttiCreateFunc.GetMethod('Invoke');
// Prepare the argument for the factory proc: a pointer to 'params'
var factoryArg: array[0..0] of TValue;
var factoryParamTypeInfo := factoryInvokeMethod.GetParameters[0].ParamType.Handle;
TValue.Make(params.RawData, factoryParamTypeInfo, factoryArg[0]);
var myProcValue := factoryInvokeMethod.Invoke(createFuncValue, factoryArg);
invoke := CreateInvoker(Ctx, myProcValue);
break;
end;
end;
//////////
Assert(Assigned(invoke));
invoke(workerValueParam, finalResultRec);
var desc := finalResultRec.GetValue<String>('desc');
var desc := res.GetValue<String>('desc');
Log.Add('Final result description: ' + desc);
Assert(desc = 'done');
end;
Src/Myc.Data.Records.pas
+117 -51
View File
@@ -32,10 +32,15 @@ type
constructor Create(const AName: string; AFieldType: TFieldType; ATypeInfo: PTypeInfo; AOffset: Integer);
procedure Copy(Src, Dst: Pointer);
function GetSize: Integer; inline;
function GetAlignedSize: Integer; inline;
public
class operator Equal(const A, B: TField): Boolean;
class operator NotEqual(const A, B: TField): Boolean; inline;
property FieldType: TFieldType read FFieldType;
property Name: string read FName;
property Size: Integer read GetSize;
@@ -54,13 +59,22 @@ type
FFields: TArray<TField>;
constructor Create(const AFields: TArray<TField>);
function GetSize: Integer;
public
class function FromRecord<T>: TLayout; static;
class function FromRecord<T>: TLayout; overload; static;
class function FromRecord(ATypeInfo: PtypeInfo): TLayout; overload; static;
class operator Equal(const A, B: TLayout): Boolean;
class operator NotEqual(const A, B: TLayout): Boolean; inline;
class function Construct(const Def: TArray<TFieldDef>): TLayout; static;
procedure Copy(Src, Dst: Pointer);
function IndexOf(const Name: String): Integer;
property Fields: TArray<TField> read FFields;
property Size: Integer read GetSize;
end;
const
@@ -110,12 +124,7 @@ constructor TDataRecord.Create(const ALayout: TLayout);
begin
FLayout := ALayout;
var bufSize := 0;
if Length(FLayout.Fields) > 0 then
with FLayout.Fields[High(FLayout.Fields)] do
bufSize := Offset + AlignedSize;
SetLength(FBuffer, bufSize);
SetLength(FBuffer, FLayout.Size);
for var i := 0 to High(FLayout.Fields) do
FLayout.Fields[i].InitField(FBuffer);
end;
@@ -269,48 +278,7 @@ end;
procedure TDataRecord.TField.FromType(const [ref] Buffer: TBytes; const Src);
begin
Assert(FOffset + Size <= Length(Buffer));
var Dst := @Buffer[FOffset];
case FFieldType of
dfFloat:
begin
Assert(FTypeInfo.Kind = tkFloat);
case GetTypeData(FTypeInfo).FloatType of
ftSingle: PSingle(Dst)^ := PSingle(@Src)^;
ftDouble: PDouble(Dst)^ := PDouble(@Src)^;
else
Assert(false);
end;
end;
dfInteger:
begin
case FTypeInfo.Kind of
tkInteger: PInteger(Dst)^ := PInteger(@Src)^;
tkInt64: PInt64(Dst)^ := PInt64(@Src)^;
else
Assert(false);
end;
end;
dfString:
begin
Assert(FTypeInfo.Kind in [tkString, tkLString, tkUString, tkWString]);
PString(Dst)^ := PString(@Src)^;
end;
dfTimestamp:
begin
Assert(FTypeInfo.Kind = tkFloat);
Assert(FTypeInfo.Name = PTypeInfo(System.TypeInfo(TDateTime)).Name);
PDateTime(Dst)^ := PDateTime(@Src)^;
end;
dfRecord:
begin
Assert(FTypeInfo = System.TypeInfo(TDataRecord));
Assert(FTypeInfo.Name = PTypeInfo(System.TypeInfo(TDataRecord)).Name);
TDataRecord(Dst^) := TDataRecord(Src);
end;
else
Assert(false);
end;
Copy(@Src, @Buffer[FOffset]);
end;
function TDataRecord.TField.GetSize: Integer;
@@ -390,6 +358,60 @@ begin
end;
end;
procedure TDataRecord.TField.Copy(Src, Dst: Pointer);
begin
case FFieldType of
dfFloat:
begin
Assert(FTypeInfo.Kind = tkFloat);
case GetTypeData(FTypeInfo).FloatType of
ftSingle: PSingle(Dst)^ := PSingle(Src)^;
ftDouble: PDouble(Dst)^ := PDouble(Src)^;
else
Assert(false);
end;
end;
dfInteger:
begin
case FTypeInfo.Kind of
tkInteger: PInteger(Dst)^ := PInteger(Src)^;
tkInt64: PInt64(Dst)^ := PInt64(Src)^;
else
Assert(false);
end;
end;
dfString:
begin
Assert(FTypeInfo.Kind in [tkString, tkLString, tkUString, tkWString]);
PString(Dst)^ := PString(Src)^;
end;
dfTimestamp:
begin
Assert(FTypeInfo.Kind = tkFloat);
Assert(FTypeInfo.Name = PTypeInfo(System.TypeInfo(TDateTime)).Name);
PDateTime(Dst)^ := PDateTime(Src)^;
end;
dfRecord:
begin
Assert(FTypeInfo = System.TypeInfo(TDataRecord));
Assert(FTypeInfo.Name = PTypeInfo(System.TypeInfo(TDataRecord)).Name);
TDataRecord(Dst^) := TDataRecord(Src^);
end;
else
Assert(false);
end;
end;
class operator TDataRecord.TField.Equal(const A, B: TField): Boolean;
begin
Result := (A.FFieldType = B.FFieldType) and (A.FTypeInfo = B.FTypeInfo) and (A.FOffset = B.FOffset) and (A.FName = B.FName);
end;
class operator TDataRecord.TField.NotEqual(const A, B: TField): Boolean;
begin
Result := not (A = B);
end;
constructor TDataRecord.TLayout.Create(const AFields: TArray<TField>);
begin
FFields := AFields;
@@ -419,12 +441,25 @@ begin
Result.Create(Fields);
end;
procedure TDataRecord.TLayout.Copy(Src, Dst: Pointer);
begin
for var i := 0 to High(FFields) do
begin
var ofs := FFields[i].Offset;
var S: PByte := Src;
inc(S, ofs);
var D: PByte := Dst;
inc(D, ofs);
FFields[i].Copy(S, D);
end;
end;
{ TLayout }
class function TDataRecord.TLayout.FromRecord<T>: TLayout;
class function TDataRecord.TLayout.FromRecord(ATypeInfo: PtypeInfo): TLayout;
begin
var ctx := TRttiContext.Create;
var rttiType := ctx.GetType(TypeInfo(T));
var rttiType := ctx.GetType(ATypeInfo);
var rttiFields := rttiType.GetFields;
var fields: TArray<TField>;
@@ -467,6 +502,21 @@ begin
Result.Create(fields);
end;
{ TLayout }
class function TDataRecord.TLayout.FromRecord<T>: TLayout;
begin
Result := FromRecord(TypeInfo(T));
end;
function TDataRecord.TLayout.GetSize: Integer;
begin
Result := 0;
if Length(FFields) > 0 then
with FFields[High(FFields)] do
Result := Offset + Size;
end;
function TDataRecord.TLayout.IndexOf(const Name: String): Integer;
begin
for var i := 0 to High(FFields) do
@@ -475,4 +525,20 @@ begin
exit(-1);
end;
class operator TDataRecord.TLayout.Equal(const A, B: TLayout): Boolean;
begin
if Length(A.FFields) <> Length(B.FFields) then
exit(false);
for var i := 0 to High(A.FFields) do
if A.FFields[i] <> B.FFields[i] then
exit(false);
exit(true);
end;
class operator TDataRecord.TLayout.NotEqual(const A, B: TLayout): Boolean;
begin
Result := not (A = B);
end;
end.