unit Myc.Ast.RTL.TypeRegistry;

interface

uses
    System.SysUtils,
    System.Classes,
    System.Rtti,
    System.TypInfo,
    System.Generics.Collections,
    Myc.Data.Value,
    Myc.Data.Scalar,
    Myc.Data.Keyword,
    Myc.Ast.Types,
    Myc.Ast.Scope,
    Myc.Ast.RTL;

type
    EInteropException = class(Exception);
    ERecursionException = class(EInteropException);

    // Factory delegate for Interfaces
    TInterfaceFactoryDelegate<T: IInterface> = reference to function(const Args: TArray<TDataValue>): T;

    //  Central registry mapping Delphi Interfaces to AST static types and handling
    //  runtime wrapping (Shadow Records).
    TRtlTypeRegistry = class
    private
        class var
            FCtx: TRttiContext;
            FKnownTypes: TDictionary<PTypeInfo, IStaticType>;
            FAnalysisStack: TList<PTypeInfo>;

        // --- Analysis ---
        class function AnalyzeType(ATypeInfo: PTypeInfo): IStaticType; static;
        class function GenerateMethodType(RType: TRttiMethodType): IStaticType; static;
        class function GenerateInterfaceDefinition(RType: TRttiInterfaceType): IStaticType; static;
        class procedure EnterAnalysis(Info: PTypeInfo); static;
        class procedure ExitAnalysis(Info: PTypeInfo); static;

        // --- Marshalling ---
        class function ToTValue(const AData: TDataValue; ATargetType: TRttiType): TValue; static;
        class function FromTValue(const AValue: TValue): TDataValue; static;

        // --- Wrapping ---
        class function WrapInstance(const Instance: IInterface; TypeInfo: PTypeInfo): TDataValue; static;

    public
        class constructor Create;
        class destructor Destroy;

        // --- Registration ---
        // Registers a Delphi Interface type. Raises ERecursionException on cycles.
        class procedure RegisterType<T: IInterface>; overload;
        class procedure RegisterType(Info: PTypeInfo); overload;

        // --- Factories ---
        // Registers a factory function. T must be registered via RegisterType<T> first.
        // UPDATED: Now supports documentation parameter.
        class procedure RegisterFactory<T: IInterface>(
            const Scope: IExecutionScope;
            const FactoryName: string;
            const FactoryArgs: TArray<IStaticType>;
            const FactoryDelegate: TInterfaceFactoryDelegate<T>;
            const Doc: string = ''
        );

        // --- Resolution ---
        class function GetStaticType(Info: PTypeInfo): IStaticType;
        class function ResolveType(RType: TRttiType): IStaticType;

        class property Context: TRttiContext read FCtx;
    end;

implementation

uses
    Myc.Ast.Evaluator,
    Myc.Ast.RTL.Core;

{ TRtlTypeRegistry }

class constructor TRtlTypeRegistry.Create;
begin
    FCtx := TRttiContext.Create;
    FKnownTypes := TDictionary<PTypeInfo, IStaticType>.Create;
    FAnalysisStack := TList<PTypeInfo>.Create;
end;

class destructor TRtlTypeRegistry.Destroy;
begin
    FAnalysisStack.Free;
    FKnownTypes.Free;
    FCtx.Free;
end;

// -----------------------------------------------------------------------------
// Type Analysis
// -----------------------------------------------------------------------------

class procedure TRtlTypeRegistry.EnterAnalysis(Info: PTypeInfo);
begin
    if FAnalysisStack.Contains(Info) then
        raise ERecursionException.CreateFmt('Recursive type definition detected for "%s".', [string(Info.Name)]);
    FAnalysisStack.Add(Info);
end;

class procedure TRtlTypeRegistry.ExitAnalysis(Info: PTypeInfo);
begin
    FAnalysisStack.Remove(Info);
end;

class procedure TRtlTypeRegistry.RegisterType<T>;
begin
    RegisterType(TypeInfo(T));
end;

class procedure TRtlTypeRegistry.RegisterType(Info: PTypeInfo);
begin
    TMonitor.Enter(FKnownTypes);
    try
        if FKnownTypes.ContainsKey(Info) then
            exit;

        EnterAnalysis(Info);
        try
            var staticType := AnalyzeType(Info);
            FKnownTypes.Add(Info, staticType);
        finally
            ExitAnalysis(Info);
        end;
    finally
        TMonitor.Exit(FKnownTypes);
    end;
end;

class function TRtlTypeRegistry.GetStaticType(Info: PTypeInfo): IStaticType;
begin
    if not FKnownTypes.TryGetValue(Info, Result) then
        Result := TTypes.Unknown;
end;

class function TRtlTypeRegistry.ResolveType(RType: TRttiType): IStaticType;
begin
    if not Assigned(RType) then
        exit(TTypes.Void);

    if FKnownTypes.TryGetValue(RType.Handle, Result) then
        exit;

    if FAnalysisStack.Contains(RType.Handle) then
        raise ERecursionException.CreateFmt('Recursive type reference detected during resolution of "%s".', [RType.Name]);

    case RType.TypeKind of
        tkInteger, tkInt64: Result := TTypes.Ordinal;
        tkFloat: Result := TTypes.Float;
        tkString, tkUString, tkWString, tkLString, tkChar, tkWChar: Result := TTypes.Text;
        tkEnumeration:
            if RType.Handle = TypeInfo(Boolean) then
                Result := TTypes.Boolean
            else
                Result := TTypes.Ordinal;
        tkInterface: raise EInteropException.CreateFmt('Interface "%s" is not registered. Call RegisterType first.', [RType.Name]);
    else
        Result := TTypes.Unknown;
    end;
end;

class function TRtlTypeRegistry.AnalyzeType(ATypeInfo: PTypeInfo): IStaticType;
var
    rType: TRttiType;
begin
    rType := FCtx.GetType(ATypeInfo);
    case rType.TypeKind of
        // Check for Anonymous Method (treated as Interface in Delphi but should be stMethod in AST)
        tkInterface:
        begin
            var rIntf := rType as TRttiInterfaceType;
            // If the Interface has an "Invoke" method and is marked as reference-to (or is generic TFunc/TProc),
            // map it directly to stMethod.
            var method := rIntf.GetMethod('Invoke');
            if Assigned(method) and (Length(rIntf.GetMethods) = 1) then
            begin
                // It is functionally a Delegate -> Map to stMethod
                var params := method.GetParameters;
                var pTypes: TArray<IStaticType>;
                SetLength(pTypes, Length(params));

                for var i := 0 to High(params) do
                    pTypes[i] := ResolveType(params[i].ParamType);

                var retType: IStaticType;
                if Assigned(method.ReturnType) then
                    retType := ResolveType(method.ReturnType)
                else
                    retType := TTypes.Void;

                Result := TTypes.CreateMethod(pTypes, retType);
            end
            else
            begin
                // Classic Interface -> Map to Generic Record
                Result := GenerateInterfaceDefinition(rIntf);
            end;
        end;

        // NEW: Support for classic method pointers (of object)
        tkMethod: Result := GenerateMethodType(rType as TRttiMethodType);

    else
        Result := ResolveType(rType);
    end;
end;

class function TRtlTypeRegistry.GenerateMethodType(RType: TRttiMethodType): IStaticType;
var
    params: TArray<TRttiParameter>;
    pTypes: TArray<IStaticType>;
    retType: IStaticType;
    i: Integer;
begin
    params := RType.GetParameters;
    SetLength(pTypes, Length(params));

    for i := 0 to High(params) do
    begin
        pTypes[i] := ResolveType(params[i].ParamType);
    end;

    if Assigned(RType.ReturnType) then
        retType := ResolveType(RType.ReturnType)
    else
        retType := TTypes.Void;

    Result := TTypes.CreateMethod(pTypes, retType);
end;

class function TRtlTypeRegistry.GenerateInterfaceDefinition(RType: TRttiInterfaceType): IStaticType;
var
    methods: TArray<TRttiMethod>;
    props: TArray<TRttiProperty>;
    fields: TList<TPair<IKeyword, IStaticType>>;

    function MakeSig(Method: TRttiMethod): IStaticType;
    var
        ps: TArray<TRttiParameter>;
        pTypes: TArray<IStaticType>;
        returnType: IStaticType;
        k: Integer;
    begin
        ps := Method.GetParameters;
        SetLength(pTypes, Length(ps));
        for k := 0 to High(ps) do
            pTypes[k] := ResolveType(ps[k].ParamType);

        if Assigned(Method.ReturnType) then
            returnType := ResolveType(Method.ReturnType)
        else
            returnType := TTypes.Void;

        Result := TTypes.CreateMethod(pTypes, returnType);
    end;

begin
    fields := TList<TPair<IKeyword, IStaticType>>.Create;
    try
        methods := RType.GetMethods;
        for var m in methods do
        begin
            // Only map standard procedures/functions
            if m.MethodKind in [mkProcedure, mkFunction] then
                fields.Add(TPair<IKeyword, IStaticType>.Create(TKeywordRegistry.Intern(m.Name), MakeSig(m)));
        end;

        props := RType.GetProperties;
        for var p in props do
        begin
            if p.IsReadable then
            begin
                var propType := ResolveType(p.PropertyType);
                var getterSig := TTypes.CreateMethod([], propType);
                fields.Add(TPair<IKeyword, IStaticType>.Create(TKeywordRegistry.Intern(p.Name), getterSig));
            end;
        end;

        var def := TGenericRecordRegistry.Intern(fields.ToArray);
        Result := TTypes.CreateGenericRecord(def);
    finally
        fields.Free;
    end;
end;

// -----------------------------------------------------------------------------
// Marshalling
// -----------------------------------------------------------------------------

class function TRtlTypeRegistry.ToTValue(const AData: TDataValue; ATargetType: TRttiType): TValue;
begin
    case AData.Kind of
        vkScalar:
        begin
            var sc := AData.AsScalar;
            case sc.Kind of
                TScalar.TKind.Ordinal:
                begin
                    if ATargetType.Handle = TypeInfo(Integer) then
                        Result := TValue.From<Integer>(Integer(sc.Value.AsInt64))
                    else if ATargetType.Handle = TypeInfo(Byte) then
                        Result := TValue.From<Byte>(Byte(sc.Value.AsInt64))
                    else if ATargetType.Handle = TypeInfo(Word) then
                        Result := TValue.From<Word>(Word(sc.Value.AsInt64))
                    else
                        Result := TValue.From<Int64>(sc.Value.AsInt64);
                end;
                TScalar.TKind.Float, TScalar.TKind.DateTime: Result := TValue.From<Double>(sc.Value.AsDouble);
                TScalar.TKind.Boolean: Result := TValue.From<Boolean>(sc.Value.AsInt64 <> 0);
                TScalar.TKind.Keyword:
                    if ATargetType.TypeKind in [tkString, tkUString, tkWString, tkLString] then
                        Result := TValue.From<String>(TKeywordRegistry.GetName(sc.Value.AsInt64))
                    else
                        Result := TValue.From<Int64>(sc.Value.AsInt64);
            end;
        end;

        vkText:
        begin
            Result := TValue.From<string>(AData.AsText);
        end;

        vkMethod:
        begin
            // We can only map script methods to Interfaces (Anonymous Methods are Interfaces).
            if ATargetType.TypeKind <> tkInterface then
                raise EInteropException.CreateFmt(
                    'Cannot marshal script method to non-interface type "%s". Target must be an interface or anonymous method.',
                    [ATargetType.Name]);

            // Cast to Interface Type
            var rIntf := ATargetType as TRttiInterfaceType;
            var scriptFunc := AData.AsMethod;

            // Create a proxy
            var vIntf :=
                TVirtualInterface.Create(
                    rIntf.Handle,
                    procedure(Method: TRttiMethod; const Args: TArray<TValue>; out Result: TValue)
                    var
                        scriptArgs: TArray<TDataValue>;
                        scriptResult: TDataValue;
                        i: Integer;
                    begin
                        // Args[0] is always the Instance (Self) for Interfaces, skip it.
                        SetLength(scriptArgs, Length(Args) - 1);
                        for i := 0 to High(scriptArgs) do
                        begin
                            scriptArgs[i] := FromTValue(Args[i + 1]);
                        end;

                        try
                            scriptResult := scriptFunc(scriptArgs);

                            // The caller comes from the Delphi world. We must ensure the TCO stack is flushed before returning.
                            TEvaluatorVisitor.HandleTCO(scriptResult);
                        except
                            on E: Exception do
                                raise EInteropException
                                    .CreateFmt('Error executing script callback for "%s.%s": %s', [rIntf.Name, Method.Name, E.Message]);
                        end;

                        if Assigned(Method.ReturnType) then
                        begin
                            Result := ToTValue(scriptResult, Method.ReturnType);
                        end;
                    end
                );

            // Extract the Interface
            var intfRef: IInterface;
            if vIntf.QueryInterface(rIntf.GUID, intfRef) = S_OK then
            begin
                // Instead of using TValue.From(intfRef) (which creates a TValue of type IInterface),
                // we force the TValue to the exact target type (e.g. TStringProc).
                // PassArg requires exact type matching for Interfaces/Anonymous Methods.

                TValue.Make(@intfRef, ATargetType.Handle, Result);
            end
            else
                raise EInteropException.CreateFmt('Failed to create virtual interface for "%s".', [rIntf.Name]);
        end;

        vkVoid:
        begin
            if ATargetType.TypeKind = tkInterface then
                raise EInteropException.Create(
                    'Cannot pass Void to Interface parameter (did you mean nil? or is your lambda returning void?)');
            Result := TValue.Empty;
        end
    else
        raise EInteropException.CreateFmt('Marshalling for DataKind %s not implemented.', [TRttiEnumerationType.GetName(AData.Kind)]);
    end;
end;

class function TRtlTypeRegistry.FromTValue(const AValue: TValue): TDataValue;
begin
    if AValue.IsEmpty then
        exit(TDataValue.Void);

    case AValue.Kind of
        tkInteger, tkInt64: Result := TScalar.FromInt64(AValue.AsInt64);
        tkFloat: Result := TScalar.FromDouble(AValue.AsExtended);
        tkString, tkUString, tkWString, tkLString: Result := AValue.AsString;
        tkEnumeration:
            if AValue.TypeInfo = TypeInfo(Boolean) then
                Result := TScalar.FromBoolean(AValue.AsBoolean)
            else
                Result := TScalar.FromInt64(AValue.AsOrdinal);

        // Recursively wrap returned interfaces
        tkInterface: Result := WrapInstance(AValue.AsInterface, AValue.TypeInfo);
    else
        raise EInteropException.CreateFmt('FromTValue: Unsupported Kind %s', [TRttiEnumerationType.GetName(AValue.Kind)]);
        Result := TDataValue.Void;
    end;
end;

// -----------------------------------------------------------------------------
// Runtime Wrapping (Shadow Record Creation)
// -----------------------------------------------------------------------------

class function TRtlTypeRegistry.WrapInstance(const Instance: IInterface; TypeInfo: PTypeInfo): TDataValue;
var
    rType: TRttiType;
    rIntf: TRttiInterfaceType;
    recFields: TDictionary<IKeyword, TDataValue>;
begin
    if Instance = nil then
        exit(TDataValue.Void);

    rType := FCtx.GetType(TypeInfo);
    if not (rType is TRttiInterfaceType) then
        exit(TDataValue.Void);

    rIntf := rType as TRttiInterfaceType;
    recFields := TDictionary<IKeyword, TDataValue>.Create;
    try
        // Wrap Methods
        for var m in rIntf.GetMethods do
        begin
            if (m.MethodKind in [mkProcedure, mkFunction]) then
            begin
                var key := TKeywordRegistry.Intern(m.Name);

                if recFields.ContainsKey(key) then
                    raise EInteropException.Create('Overloading not supported');

                var methodFactory :=
                    function(const Instance: IInterface; Meth: TRttiMethod): TDataValue.TFunc
                    begin
                        var inst := TValue.From(Instance);
                        var params := Meth.GetParameters;
                        Result :=
                            function(const Args: TArray<TDataValue>): TDataValue
                            var
                                rttiArgs: TArray<TValue>;
                                res: TValue;
                                i: Integer;
                            begin
                                if Length(Args) <> Length(params) then
                                    raise Exception.CreateFmt('Method %s expects %d args', [m.Name, Length(params)]);

                                SetLength(rttiArgs, Length(params));
                                for i := 0 to High(params) do
                                    rttiArgs[i] := ToTValue(Args[i], params[i].ParamType);

                                res := Meth.Invoke(inst, rttiArgs);

                                Result := FromTValue(res);
                            end;
                    end;

                recFields.Add(key, methodFactory(Instance, m));
            end;
        end;

        Result := TGenericRecord<TDataValue>.Create(recFields.ToArray);
    finally
        recFields.Free;
    end;
end;

// -----------------------------------------------------------------------------
// Factories
// -----------------------------------------------------------------------------

class procedure TRtlTypeRegistry.RegisterFactory<T>(
    const Scope: IExecutionScope;
    const FactoryName: string;
    const FactoryArgs: TArray<IStaticType>;
    const FactoryDelegate: TInterfaceFactoryDelegate<T>;
    const Doc: string
);
var
    staticType: IStaticType;
    ti: PTypeInfo;
begin
    ti := TypeInfo(T);
    staticType := GetStaticType(ti);
    if staticType.Kind = stUnknown then
        raise EInteropException.CreateFmt('Interface "%s" must be registered via RegisterType<T> first.', [string(ti.Name)]);

    var factoryWrapper: TDataValue.TFunc :=
        function(const Args: TArray<TDataValue>): TDataValue
        var
            instance: T;
        begin
            instance := FactoryDelegate(Args);
            // Result wrapping will handle reference counting via closures
            Result := WrapInstance(instance, ti);
        end;

    var factorySig := TTypes.CreateMethod(FactoryArgs, staticType);
    Scope.Define(FactoryName, TDataValue(factoryWrapper), factorySig, Doc);
end;

end.