RTL custom interface types as records
This commit is contained in:
Michael Schimmel
@@ -0,0 +1,481 @@
|
||||
unit Test.Myc.Ast.RTL.TypeRegistry;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
System.SysUtils,
|
||||
System.Classes,
|
||||
System.Rtti,
|
||||
DUnitX.TestFramework,
|
||||
Myc.Data.Value,
|
||||
Myc.Data.Scalar,
|
||||
Myc.Ast.Types,
|
||||
Myc.Ast.Scope,
|
||||
Myc.Ast.Script,
|
||||
Myc.Ast.Environment,
|
||||
Myc.Ast.Evaluator,
|
||||
Myc.Ast.RTL.TypeRegistry,
|
||||
Myc.Ast; // Facade for parsing
|
||||
|
||||
type
|
||||
// --- Mocks & Interfaces for Testing ---
|
||||
|
||||
// Ein untergeordnetes Interface für rekursive Tests
|
||||
ISubService = interface(IInvokable)
|
||||
['{B1E8A9C4-1234-4321-ABCD-1234567890AB}']
|
||||
function GetName: string;
|
||||
function Multiply(A, B: Integer): Int64;
|
||||
end;
|
||||
|
||||
IUnknownService = interface(IInvokable)
|
||||
['{DEADBEEF-0000-0000-0000-000000000000}']
|
||||
procedure DoNothing;
|
||||
end;
|
||||
|
||||
// Das Haupt-Interface
|
||||
IMainService = interface(IInvokable)
|
||||
['{A1E8A9C4-1111-2222-3333-444455556666}']
|
||||
// Basic Methods
|
||||
function Add(A, B: Integer): Integer;
|
||||
procedure SetStatus(const Msg: string);
|
||||
|
||||
// Properties
|
||||
function GetCounter: Integer;
|
||||
property Counter: Integer read GetCounter;
|
||||
|
||||
// Recursion / Complex Return Types
|
||||
function CreateSub(const Name: string): ISubService;
|
||||
|
||||
// Edge Cases
|
||||
function EchoFloat(val: Double): Double;
|
||||
end;
|
||||
|
||||
// --- New Interfaces for Corner Cases ---
|
||||
|
||||
// 1. Inheritance Hierarchy
|
||||
IAncestorService = interface(IInvokable)
|
||||
['{11111111-0000-0000-0000-111111111111}']
|
||||
function AncestorMethod: string;
|
||||
end;
|
||||
|
||||
IDescendantService = interface(IAncestorService)
|
||||
['{22222222-0000-0000-0000-222222222222}']
|
||||
function DescendantMethod: string;
|
||||
end;
|
||||
|
||||
// 2. Complex Edge Cases (Void, Errors, Nil, Overloads)
|
||||
IEdgeCaseService = interface(IInvokable)
|
||||
['{EEEEEEEE-0000-0000-0000-EEEEEEEEEEEE}']
|
||||
// Void return (Procedure)
|
||||
procedure DoSomethingVoid;
|
||||
|
||||
// Native Exception
|
||||
procedure TriggerError(const Msg: string);
|
||||
|
||||
// Nil Interface return
|
||||
function GetNullService: IAncestorService;
|
||||
end;
|
||||
|
||||
[TestFixture]
|
||||
[IgnoreMemoryLeaks]
|
||||
TTestRtlTypeRegistry = class
|
||||
private
|
||||
FScope: IExecutionScope;
|
||||
FEnv: TAstEnvironment;
|
||||
public
|
||||
[Setup]
|
||||
procedure Setup;
|
||||
[TearDown]
|
||||
procedure TearDown;
|
||||
|
||||
// --- Original Tests ---
|
||||
[Test]
|
||||
procedure Test_TypeRegistration_Analysis;
|
||||
|
||||
[Test]
|
||||
procedure Test_Factory_And_MethodCall;
|
||||
|
||||
[Test]
|
||||
procedure Test_PropertyAccess;
|
||||
|
||||
[Test]
|
||||
procedure Test_Recursive_Interface_Wrapping;
|
||||
|
||||
[Test]
|
||||
procedure Test_Marshalling_EdgeCases;
|
||||
|
||||
[Test]
|
||||
procedure Test_Error_MissingRegistration;
|
||||
|
||||
// --- New Corner Case Tests ---
|
||||
[Test]
|
||||
procedure Test_Inheritance_CallAncestorMethod;
|
||||
|
||||
[Test]
|
||||
procedure Test_VoidProcedure;
|
||||
|
||||
[Test]
|
||||
procedure Test_NativeException_Propagates;
|
||||
|
||||
[Test]
|
||||
procedure Test_ReturnNilInterface;
|
||||
|
||||
[Test]
|
||||
procedure Test_UnsupportedType_Marshalling;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
System.TypInfo,
|
||||
Myc.Ast.Nodes;
|
||||
|
||||
// --- Mock Implementations ---
|
||||
|
||||
type
|
||||
TSubService = class(TInterfacedObject, ISubService)
|
||||
private
|
||||
FName: string;
|
||||
public
|
||||
constructor Create(const AName: string);
|
||||
function GetName: string;
|
||||
function Multiply(A, B: Integer): Int64;
|
||||
end;
|
||||
|
||||
TMainService = class(TInterfacedObject, IMainService)
|
||||
private
|
||||
FCount: Integer;
|
||||
FLastStatus: string;
|
||||
public
|
||||
constructor Create;
|
||||
function Add(A, B: Integer): Integer;
|
||||
procedure SetStatus(const Msg: string);
|
||||
function GetCounter: Integer;
|
||||
function CreateSub(const Name: string): ISubService;
|
||||
function EchoFloat(val: Double): Double;
|
||||
property LastStatus: string read FLastStatus;
|
||||
end;
|
||||
|
||||
TInheritanceService = class(TInterfacedObject, IDescendantService)
|
||||
public
|
||||
function AncestorMethod: string;
|
||||
function DescendantMethod: string;
|
||||
end;
|
||||
|
||||
TEdgeCaseService = class(TInterfacedObject, IEdgeCaseService)
|
||||
private
|
||||
FVoidCalled: Boolean;
|
||||
public
|
||||
procedure DoSomethingVoid;
|
||||
procedure TriggerError(const Msg: string);
|
||||
function GetNullService: IAncestorService;
|
||||
property VoidCalled: Boolean read FVoidCalled;
|
||||
end;
|
||||
|
||||
{ TSubService }
|
||||
|
||||
constructor TSubService.Create(const AName: string);
|
||||
begin
|
||||
FName := AName;
|
||||
end;
|
||||
|
||||
function TSubService.GetName: string;
|
||||
begin
|
||||
Result := FName;
|
||||
end;
|
||||
|
||||
function TSubService.Multiply(A, B: Integer): Int64;
|
||||
begin
|
||||
Result := Int64(A) * Int64(B);
|
||||
end;
|
||||
|
||||
{ TMainService }
|
||||
|
||||
constructor TMainService.Create;
|
||||
begin
|
||||
FCount := 0;
|
||||
end;
|
||||
|
||||
function TMainService.Add(A, B: Integer): Integer;
|
||||
begin
|
||||
Result := A + B;
|
||||
Inc(FCount);
|
||||
end;
|
||||
|
||||
function TMainService.CreateSub(const Name: string): ISubService;
|
||||
begin
|
||||
Result := TSubService.Create(Name);
|
||||
Inc(FCount);
|
||||
end;
|
||||
|
||||
function TMainService.EchoFloat(val: Double): Double;
|
||||
begin
|
||||
Result := val;
|
||||
end;
|
||||
|
||||
function TMainService.GetCounter: Integer;
|
||||
begin
|
||||
Result := FCount;
|
||||
end;
|
||||
|
||||
procedure TMainService.SetStatus(const Msg: string);
|
||||
begin
|
||||
FLastStatus := Msg;
|
||||
end;
|
||||
|
||||
{ TInheritanceService }
|
||||
|
||||
function TInheritanceService.AncestorMethod: string;
|
||||
begin
|
||||
Result := 'Ancestor';
|
||||
end;
|
||||
|
||||
function TInheritanceService.DescendantMethod: string;
|
||||
begin
|
||||
Result := 'Descendant';
|
||||
end;
|
||||
|
||||
procedure TEdgeCaseService.DoSomethingVoid;
|
||||
begin
|
||||
FVoidCalled := True;
|
||||
end;
|
||||
|
||||
function TEdgeCaseService.GetNullService: IAncestorService;
|
||||
begin
|
||||
Result := nil;
|
||||
end;
|
||||
|
||||
procedure TEdgeCaseService.TriggerError(const Msg: string);
|
||||
begin
|
||||
raise Exception.Create(Msg);
|
||||
end;
|
||||
|
||||
// --- Tests ---
|
||||
|
||||
procedure TTestRtlTypeRegistry.Setup;
|
||||
begin
|
||||
// 1. Create Clean Environment
|
||||
FEnv := TAstEnvironment.Construct(nil);
|
||||
FEnv.SetStandardMode;
|
||||
FScope := FEnv.RootScope;
|
||||
|
||||
// 2. Register Standard Mocks
|
||||
TRtlTypeRegistry.RegisterType<ISubService>;
|
||||
TRtlTypeRegistry.RegisterType<IMainService>;
|
||||
|
||||
TRtlTypeRegistry.RegisterFactory<IMainService>(
|
||||
FScope,
|
||||
'create-service',
|
||||
[],
|
||||
function(const Args: TArray<TDataValue>): IMainService begin Result := TMainService.Create; end
|
||||
);
|
||||
|
||||
// 3. Register Corner Case Mocks
|
||||
TRtlTypeRegistry.RegisterType<IAncestorService>;
|
||||
TRtlTypeRegistry.RegisterType<IDescendantService>;
|
||||
TRtlTypeRegistry.RegisterType<IEdgeCaseService>;
|
||||
|
||||
TRtlTypeRegistry.RegisterFactory<IDescendantService>(
|
||||
FScope,
|
||||
'create-descendant',
|
||||
[],
|
||||
function(const Args: TArray<TDataValue>): IDescendantService begin Result := TInheritanceService.Create; end
|
||||
);
|
||||
|
||||
TRtlTypeRegistry.RegisterFactory<IEdgeCaseService>(
|
||||
FScope,
|
||||
'create-edge',
|
||||
[],
|
||||
function(const Args: TArray<TDataValue>): IEdgeCaseService begin Result := TEdgeCaseService.Create; end
|
||||
);
|
||||
end;
|
||||
|
||||
procedure TTestRtlTypeRegistry.TearDown;
|
||||
begin
|
||||
// Interfaces are ref-counted, scope cleanup handles values.
|
||||
FScope := nil;
|
||||
end;
|
||||
|
||||
procedure TTestRtlTypeRegistry.Test_TypeRegistration_Analysis;
|
||||
var
|
||||
staticType: IStaticType;
|
||||
genRec: IGenericRecordDefinition;
|
||||
idx: Integer;
|
||||
methodType: IStaticType;
|
||||
begin
|
||||
// Verify that IMainService was analyzed correctly into an AST definition
|
||||
staticType := TRtlTypeRegistry.GetStaticType(TypeInfo(IMainService));
|
||||
|
||||
Assert.AreNotEqual(TStaticTypeKind.stUnknown, staticType.Kind, 'Type should be known');
|
||||
Assert.AreEqual(TStaticTypeKind.stGenericRecord, staticType.Kind, 'Interface should map to GenericRecord');
|
||||
|
||||
genRec := staticType.GenericDefinition;
|
||||
|
||||
// Check 'Add' method existence
|
||||
idx := genRec.IndexOf(Myc.Data.Keyword.TKeywordRegistry.Intern('Add'));
|
||||
Assert.IsTrue(idx >= 0, 'Method Add should exist in type definition');
|
||||
|
||||
methodType := genRec.Items[idx].Value;
|
||||
Assert.AreEqual(TStaticTypeKind.stMethod, methodType.Kind);
|
||||
// Add has 2 args (Ordinal, Ordinal) -> Ordinal
|
||||
Assert.AreEqual(Int64(2), Length(methodType.Signatures[0].ParamTypes));
|
||||
Assert.AreEqual(TStaticTypeKind.stOrdinal, methodType.Signatures[0].ReturnType.Kind);
|
||||
end;
|
||||
|
||||
procedure TTestRtlTypeRegistry.Test_Factory_And_MethodCall;
|
||||
var
|
||||
script: string;
|
||||
res: TDataValue;
|
||||
begin
|
||||
// Script: Create service, call Add(10, 20)
|
||||
script := '(do ' + ' (def svc (create-service)) ' + ' ((.Add svc) 10 20) ' + ')';
|
||||
|
||||
var root := TAstScript.Parse(script);
|
||||
|
||||
res := FEnv.Run(root);
|
||||
|
||||
Assert.AreEqual(TDataValueKind.vkScalar, res.Kind);
|
||||
Assert.AreEqual(Int64(30), res.AsScalar.Value.AsInt64);
|
||||
end;
|
||||
|
||||
procedure TTestRtlTypeRegistry.Test_PropertyAccess;
|
||||
var
|
||||
script: string;
|
||||
res: TDataValue;
|
||||
begin
|
||||
// Script: Call Add twice (increments counter), then read Counter property
|
||||
script :=
|
||||
'(do '
|
||||
+ ' (def svc (create-service)) '
|
||||
+ ' ((.Add svc) 1 1) '
|
||||
+ ' ((.Add svc) 2 2) '
|
||||
+ ' ((.GetCounter svc)) '
|
||||
+ // Property is a getter-function in script!
|
||||
')';
|
||||
|
||||
var root := TAstScript.Parse(script);
|
||||
res := FEnv.Run(root);
|
||||
|
||||
Assert.AreEqual(vkScalar, res.Kind);
|
||||
Assert.AreEqual(Int64(2), res.AsScalar.Value.AsInt64);
|
||||
end;
|
||||
|
||||
procedure TTestRtlTypeRegistry.Test_Recursive_Interface_Wrapping;
|
||||
var
|
||||
script: string;
|
||||
res: TDataValue;
|
||||
begin
|
||||
// Script:
|
||||
// 1. Create MainService
|
||||
// 2. Call CreateSub("TestSub") -> Returns ISubService (Wrapped automatically!)
|
||||
// 3. Call Multiply on that SubService
|
||||
|
||||
script := '(do ' + ' (def svc (create-service)) ' + ' (def sub ((.CreateSub svc) "TestSub")) ' + ' ((.Multiply sub) 6 7) ' + ')';
|
||||
|
||||
var root := TAstScript.Parse(script);
|
||||
res := FEnv.Run(root);
|
||||
|
||||
Assert.AreEqual(Int64(42), res.AsScalar.Value.AsInt64);
|
||||
end;
|
||||
|
||||
procedure TTestRtlTypeRegistry.Test_Marshalling_EdgeCases;
|
||||
var
|
||||
script: string;
|
||||
res: TDataValue;
|
||||
begin
|
||||
// Test Float Marshalling and String
|
||||
// Script: Pass a float, get it back.
|
||||
|
||||
script := '(do ' + ' (def svc (create-service)) ' + ' ((.EchoFloat svc) 3.1415) ' + ')';
|
||||
|
||||
var root := TAstScript.Parse(script);
|
||||
res := FEnv.Run(root);
|
||||
|
||||
Assert.AreEqual(3.1415, res.AsScalar.Value.AsDouble, 0.0001);
|
||||
end;
|
||||
|
||||
procedure TTestRtlTypeRegistry.Test_Error_MissingRegistration;
|
||||
begin
|
||||
// Try to create factory without registering type
|
||||
Assert.WillRaise(procedure begin TRtlTypeRegistry.RegisterFactory<IUnknownService>(FScope, 'fail', [], nil); end, EInteropException);
|
||||
end;
|
||||
|
||||
// --- New Corner Cases ---
|
||||
|
||||
procedure TTestRtlTypeRegistry.Test_Inheritance_CallAncestorMethod;
|
||||
var
|
||||
script: string;
|
||||
res: TDataValue;
|
||||
begin
|
||||
// Test if we can call a method defined in the parent interface
|
||||
// on an instance of the child interface.
|
||||
script :=
|
||||
'(do '
|
||||
+ ' (def svc (create-descendant)) '
|
||||
+ ' (def val1 ((.DescendantMethod svc))) '
|
||||
+ ' (def val2 ((.AncestorMethod svc))) '
|
||||
+ ' (+ val1 val2) '
|
||||
+ ')';
|
||||
|
||||
var root := TAstScript.Parse(script);
|
||||
res := FEnv.Run(root);
|
||||
|
||||
Assert.AreEqual(TDataValueKind.vkText, res.Kind);
|
||||
Assert.AreEqual('DescendantAncestor', res.AsText);
|
||||
end;
|
||||
|
||||
procedure TTestRtlTypeRegistry.Test_VoidProcedure;
|
||||
var
|
||||
script: string;
|
||||
res: TDataValue;
|
||||
begin
|
||||
// Procedures (void return) should return vkVoid in AST
|
||||
script := '(do ' + ' (def svc (create-edge)) ' + ' ((.DoSomethingVoid svc)) ' + ')';
|
||||
|
||||
var root := TAstScript.Parse(script);
|
||||
res := FEnv.Run(root);
|
||||
|
||||
Assert.IsTrue(res.IsVoid, 'Procedures should return Void TDataValue');
|
||||
end;
|
||||
|
||||
procedure TTestRtlTypeRegistry.Test_NativeException_Propagates;
|
||||
var
|
||||
script: string;
|
||||
begin
|
||||
// Verify that a Delphi exception crashes the script execution properly
|
||||
script := '(do ' + ' (def svc (create-edge)) ' + ' ((.TriggerError svc) "Boom!") ' + ')';
|
||||
|
||||
var root := TAstScript.Parse(script);
|
||||
|
||||
Assert.WillRaise(procedure begin FEnv.Run(root); end, EEvaluatorException, 'Boom!');
|
||||
end;
|
||||
|
||||
procedure TTestRtlTypeRegistry.Test_ReturnNilInterface;
|
||||
var
|
||||
script: string;
|
||||
res: TDataValue;
|
||||
begin
|
||||
// If a Delphi function returns nil, the AST value should be Void or handle it gracefully
|
||||
script := '(do ' + ' (def svc (create-edge)) ' + ' ((.GetNullService svc)) ' + ')';
|
||||
|
||||
var root := TAstScript.Parse(script);
|
||||
res := FEnv.Run(root);
|
||||
|
||||
if res.Kind = vkInterface then
|
||||
Assert.IsNull(res.AsIntf<IInterface>, 'Returned interface should be nil')
|
||||
else
|
||||
Assert.IsTrue(res.IsVoid, 'Nil result should be mapped to Void');
|
||||
end;
|
||||
|
||||
procedure TTestRtlTypeRegistry.Test_UnsupportedType_Marshalling;
|
||||
begin
|
||||
// This expects the runtime to throw an error when converting TValue or invoking
|
||||
// due to invalid argument types (passing string where int is expected).
|
||||
var script := '(do ' + ' (def svc (create-edge)) ' + ' ((.Calc svc) "Not a number") ' + ')';
|
||||
|
||||
var root := TAstScript.Parse(script);
|
||||
|
||||
Assert.WillRaise(procedure begin FEnv.Run(root); end);
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user