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];
    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);
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.