unit uTypeInfo;

interface

uses Classes, TypInfo, Rubies;

var
  cTypeInfo, cTypeData: Tvalue;
  vTypeInfo: Tvalue;

function ap_vTypeInfo: Tvalue;

procedure TypeInfo_setup_internal(This: Tvalue; real: PTypeInfo); cdecl;
procedure TypeInfo_setup_TypeData(This: Tvalue; real: PTypeInfo); cdecl;
function TypeInfo_new(This, v: Tvalue): Tvalue; cdecl;
procedure Init_TypeInfo;

implementation

uses
{$IFDEF LINUX}
  Types,
{$ENDIF}
{$IFDEF MSWINDOWS}
  Windows, {ComObj, }
{$ENDIF}
  SysUtils,
  uStrUtils,
  uHandle, uPhi, uProp, uError, uDebug, uIO, uConv,
  uPropInfo;

function ap_vTypeInfo: Tvalue;
begin
  result := vTypeInfo;
end;

function ap_ClassTypeDataItems(real: PTypeInfo; Count: Integer): Tvalue;
var
  APropList: TPropList;
  APropInfo: PPropInfo;
  vPropInfo: Tvalue;
  i: Integer;
begin
  GetPropInfos(real, @APropList);
  result := rb_ary_new;
  for i := 0 to Count-1 do
  begin
    APropInfo := APropList[i];
    vPropInfo := rb_data_object_alloc(cPropInfo, APropInfo, nil, nil);
    PropInfo_setup(vPropInfo, APropInfo);
    rb_ary_push(result, vPropInfo);
  end;
end;

function ap_MethodTypeDataItems(P: PChar; Count: Integer): Tvalue;
var
  ary: Tvalue;
  i: Integer;
begin
  result := rb_ary_new;
  for i := 0 to Count-1 do
  begin
    ary := rb_ary_new;
    rb_ary_push(ary, ap_Set(P^));
    Inc(P);
    rb_ary_push(ary, rb_str_new(P+1, Ord(P^)));
    Inc(P, Ord(P^)+1);
    rb_ary_push(ary, rb_str_new(P+1, Ord(P^)));
    Inc(P, Ord(P^)+1);
    rb_ary_push(result, ary);
  end;
end;

procedure TypeInfo_setup_internal(This: Tvalue; real: PTypeInfo); cdecl;
begin
  rb_iv_set(This, '@kind', INT2FIX(Ord(real^.Kind)));
  rb_iv_set(This, '@name', ap_String(string(real^.Name)));
end;

procedure TypeInfo_setup_TypeData(This: Tvalue; real: PTypeInfo); cdecl;
var
  AData: PTypeData;
  vData: Tvalue;
  Count: Integer;

  function ap_TypeDataType(real: PTypeInfo): Tvalue;
  begin
    result := rb_data_object_alloc(cTypeInfo, real, nil, nil);
    TypeInfo_setup_internal(result, real);
  end;
(*
  function ap_IntfFlags(IntfFlags: TIntfFlagsBase): Tvalue;
  begin
    result := ap_Set(IntfFlags);
  end;
*)
begin
  AData := GetTypeData(real);
  vData := rb_data_object_alloc(cTypeData, AData, nil, nil);
  rb_iv_set(This, '@type_data', vData);

  case real^.Kind of
  tkInteger, tkChar, tkWChar:
    begin
      rb_iv_set(vData, '@ord_type', INT2FIX(Ord(AData^.OrdType)));
      rb_iv_set(vData, '@min_value', rb_int2inum(AData^.MinValue));
      rb_iv_set(vData, '@max_value', rb_int2inum(AData^.MaxValue));
    end;
  tkEnumeration:
    begin
      rb_iv_set(vData, '@ord_type', INT2FIX(Ord(AData^.OrdType)));
      rb_iv_set(vData, '@min_value', rb_int2inum(AData^.MinValue));
      rb_iv_set(vData, '@max_value', rb_int2inum(AData^.MaxValue));
      rb_iv_set(vData, '@base_type', ap_TypeDataType(AData^.BaseType^));
    //rb_iv_set(vData, '@name_list', ap_String(string(AData^.NameList)));
    end;
  tkSet:
    begin
      rb_iv_set(vData, '@ord_type', INT2FIX(Ord(AData^.OrdType)));
      rb_iv_set(vData, '@comp_type', ap_TypeDataType(AData^.CompType^));
    end;
  tkFloat:
    begin
      rb_iv_set(vData, '@float_type', INT2FIX(Ord(AData^.FloatType)));
    end;
  tkString:
    begin
      rb_iv_set(vData, '@max_length', INT2FIX(Ord(AData^.MaxLength)));
    end;
  tkClass:
    begin
      rb_iv_set(vData, '@class_type', ap_TypeDataType(PTypeInfo(AData^.ClassType.ClassInfo)));
      rb_iv_set(vData, '@parent_info', ap_TypeDataType(AData^.ParentInfo^));
      Count := AData^.PropCount;
      rb_iv_set(vData, '@count', INT2FIX(Count));
      rb_iv_set(vData, '@items', ap_ClassTypeDataItems(real, Count));
      rb_iv_set(vData, '@unit_name', ap_String(string(AData^.UnitName)));
    end;
  tkMethod:
    begin
      rb_iv_set(vData, '@method_kind', INT2FIX(Ord(AData^.MethodKind)));
      Count := AData^.ParamCount;
      rb_iv_set(vData, '@count', INT2FIX(Count));
      rb_iv_set(vData, '@items', ap_MethodTypeDataItems(@AData^.ParamList, Count));
    end;
(*
  tkInterface:
    begin
      rb_iv_set(vData, '@intf_parent', ap_TypeDataType(AData^.IntfParent^));
      rb_iv_set(vData, '@intf_flags', ap_IntfFlags(AData^.IntfFlags));
      rb_iv_set(vData, '@guid', ap_String(GUIDToString(AData^.GUID)));
      rb_iv_set(vData, '@intf_unit', ap_String(string(AData^.IntfUnit)));
    end;
*)
  tkInt64:
    begin
      rb_iv_set(vData, '@min_value', rb_int2inum(AData^.MinInt64Value));
      rb_iv_set(vData, '@max_value', rb_int2inum(AData^.MaxInt64Value));
    end;
  end;
end;

function TypeInfo_new(This, v: Tvalue): Tvalue; cdecl;
var
  real: PTypeInfo;
begin
  real := ap_data_get_struct(rb_iv_get(v, '_class'));
  if real = nil then
    result := Qnil
  else
  begin
    result := rb_data_object_alloc(cTypeInfo, real, nil, nil);
    TypeInfo_setup_internal(result, real);
    TypeInfo_setup_TypeData(result, real);
  end;
end;

function TypeInfo_to_s(This: Tvalue): Tvalue; cdecl;
var
  klass: Tvalue;
  vkind: Tvalue;
begin
  result := rb_str_new2('#');
  rb_str_cat(result, '<', 1);

  klass := CLASS_OF(This);
  klass := rb_class_path(klass);
  rb_str_concat(result, klass);
  rb_str_cat(result, ':', 1);

  ap_str_cat(result, ' kind=');
  vkind := rb_iv_get(This, '@kind');
  ap_str_cat(result, GetEnumName0(TypeInfo(TTypeKind), FIX2INT(vkind)));
  ap_str_cat(result, ' name=');
  rb_str_concat(result, rb_str_inspect(rb_iv_get(This, '@name')));

  rb_str_cat(result, '>', 1);
end;

function TypeInfo_use_type_data(This: Tvalue): Tvalue; cdecl;
var
  real: PTypeInfo;
begin
  real := ap_data_get_struct(This);
  TypeInfo_setup_TypeData(This, real);
  result := This;
end;

function TypeInfo_enum_name(This, v: Tvalue): Tvalue; cdecl;
var
  real: PTypeInfo;
begin
  real := ap_data_get_struct(This);
  result := ap_String(GetEnumName(real, dl_Integer(v)));
end;

procedure Init_TypeInfo;
begin
  vTypeInfo := rb_hash_new;
  rb_define_const(mPhi, 'TYPE_INFO', vTypeInfo);

  cTypeInfo := rb_define_class_under(mPhi, 'TypeInfo', ap_cObject);
  rb_define_singleton_method(cTypeInfo, 'new', @TypeInfo_new, 1);
  rb_define_method(cTypeInfo, 'to_s', @TypeInfo_to_s, 0);
  rb_define_method(cTypeInfo, 'use_type_data', @TypeInfo_use_type_data, 0);
  rb_define_method(cTypeInfo, 'enum_name', @TypeInfo_enum_name, 1);
  rb_define_attr(cTypeInfo, 'kind', 1, 0);
  rb_define_attr(cTypeInfo, 'name', 1, 0);
  rb_define_attr(cTypeInfo, 'type_data', 1, 0);

  cTypeData := rb_define_class_under(mPhi, 'TypeData', ap_cObject);
  rb_define_attr(cTypeData, 'count', 1, 0);
  rb_define_attr(cTypeData, 'items', 1, 0);
  rb_define_attr(cTypeData, 'ord_type', 1, 0);
  rb_define_attr(cTypeData, 'min_value', 1, 0);
  rb_define_attr(cTypeData, 'max_value', 1, 0);
  rb_define_attr(cTypeData, 'base_type', 1, 0);
//rb_define_attr(cTypeData, 'name_list', 1, 0);
  rb_define_attr(cTypeData, 'comp_type', 1, 0);
  rb_define_attr(cTypeData, 'float_type', 1, 0);
  rb_define_attr(cTypeData, 'max_length', 1, 0);
  rb_define_attr(cTypeData, 'class_type', 1, 0);
  rb_define_attr(cTypeData, 'parent_info', 1, 0);
  rb_define_attr(cTypeData, 'unit_name', 1, 0);
  rb_define_attr(cTypeData, 'method_kind', 1, 0);
(*
  rb_define_attr(cTypeData, 'intf_parent', 1, 0);
  rb_define_attr(cTypeData, 'intf_flags', 1, 0);
  rb_define_attr(cTypeData, 'guid', 1, 0);
  rb_define_attr(cTypeData, 'intf_unit', 1, 0);
*)

  OutputConstSetType(mPhi, TypeInfo(TTypeKind));
  OutputConstSetType(mPhi, TypeInfo(TOrdType));
  OutputConstSetType(mPhi, TypeInfo(TFloatType));
  OutputConstSetType(mPhi, TypeInfo(TMethodKind));
  OutputConstSetType(mPhi, TypeInfo(TParamFlag));
(*
  OutputConstSetType(mPhi, TypeInfo(TIntfFlag));
*)
end;

end.
