unit XData.JSchema.ObjectGenerator;

interface

uses
  Bcl.Collections, Generics.Collections,
  Bcl.Json.Converters,
  System.Rtti, System.TypInfo,
  XData.JSchema.Classes,
  XData.JSchema.Generators;

type
  TJSchemaBoundField = class
  private
    FName: string;
    FMember: TRttiMember;
    FDeserialize: Boolean;
    FSerialize: Boolean;
    function GetMemberType: TRttiType;
  public
    constructor Create(const AName: string; ASerialize, ADeserialize: Boolean);
    property Name: string read FName;
    property Serialize: Boolean read FSerialize;
    property Deserialize: Boolean read FDeserialize;
    property Member: TRttiMember read FMember write FMember;
    property MemberType: TRttiType read GetMemberType;
  end;

  TJSchemaObjectGenerator = class(TJSchemaGenerator)
  private
    FClass: TClass;
    FBoundFields: TDictionary<TClass, TList<TJSchemaBoundField>>;
    {$IFDEF AUTOREFCOUNT}[Weak]{$ENDIF}
    FGenerators: TJSchemaGenerators;
    FContext: TRttiContext;
    property Generators: TJSchemaGenerators read FGenerators;
  private
    procedure LoadBoundFields(AClass: TClass; AFields: TList<TJSchemaBoundField>);
    function GetBoundFields(AClass: TClass): TList<TJSchemaBoundField>;
    function GetMemberName(RttiMember: TRttiMember; AStrategy: IJsonNamingStrategy): string;
  public
    constructor Create(AClass: TClass; AGenerators: TJSchemaGenerators);
    destructor Destroy; override;
    function CreateSchema: TJsonSchema; override;
  end;

  TJSchemaObjectGeneratorFactory = class(TInterfacedObject, IJSchemaGeneratorFactory)
  strict protected
    function CreateGenerator(Context: TJSchemaGeneratorContext; const ATypeToken: TTypeToken): IJSchemaGenerator;
  end;

implementation

uses
  Bcl.Json.Attributes,
  Bcl.Json.NamingStrategies,
  Bcl.Rtti.Utils;

{ TJSchemaObjectGenerator }

constructor TJSchemaObjectGenerator.Create(AClass: TClass;
  AGenerators: TJSchemaGenerators);
begin
  FClass := AClass;
  FGenerators := AGenerators;
  FContext := TRttiContext.Create;
  FBoundFields := TObjectDictionary<TClass, TList<TJSchemaBoundField>>.Create([doOwnsValues]);
end;

function TJSchemaObjectGenerator.CreateSchema: TJsonSchema;
var
  Schema: TObjectSchema;
  PropSchema: TJsonSchema;
  Field: TJSchemaBoundField;

begin
  { We are repeating lots of code here from Bcl.Json.ObjectConverter. This should be
    refactored eventually. For now, pay attention to any change in that unit that
    needs to be reflected here }
  Schema := TObjectSchema.Create;
  try
    Generators.TrySchemaDefinitions(Schema.Definitions);

    for Field in GetBoundFields(FClass) do
    begin
      if Field.MemberType.IsInstance then
      begin
        PropSchema := Generators.ProcessRef(Field.MemberType.Handle);
      end
      else
        PropSchema := Generators.Get(Field.MemberType.Handle).CreateSchema;
      Schema.Properties.Add(Field.Name, PropSchema);

//      PropSchema.CustomData.Add('x-data-type', TJPrimitive.Create(Prop.PropertyType.QualifiedName));
//      PropSchema.Description := Prop.Description;
    end;
    Result := Schema;
  except
    Schema.Free;
    raise;
  end;
end;

destructor TJSchemaObjectGenerator.Destroy;
begin
  FContext.Free;
  FBoundFields.Free;
  inherited;
end;

function TJSchemaObjectGenerator.GetBoundFields(
  AClass: TClass): TList<TJSchemaBoundField>;
begin
  if not FBoundFields.TryGetValue(AClass, Result) then
  begin
    Result := TObjectList<TJSchemaBoundField>.Create(True);
    FBoundFields.Add(AClass, Result);
    LoadBoundFields(AClass, Result);
  end;
end;

function TJSchemaObjectGenerator.GetMemberName(RttiMember: TRttiMember;
  AStrategy: IJsonNamingStrategy): string;
var
  A: JsonPropertyAttribute;
begin
  if TRttiUtils.GetInstance.TryGetAttribute<JsonPropertyAttribute>(RttiMember, A)
    and (A.Name <> '') then
    Result := A.Name
  else
    Result := AStrategy.ResolveName(RttiMember);
end;

procedure TJSchemaObjectGenerator.LoadBoundFields(AClass: TClass;
  AFields: TList<TJSchemaBoundField>);
var
  ClassType: TRttiType;
  RttiField: TRttiField;
  RttiProp: TRttiProperty;
  BoundField: TJSchemaBoundField;
  NamingAttr: JsonNamingStrategyAttribute;
  NamingStrategy: IJsonNamingStrategy;
begin
  if AClass = TObject then Exit;
  ClassType := FContext.GetType(AClass);
  if TRttiUtils.GetInstance.TryGetAttribute<JsonNamingStrategyAttribute>(ClassType, NamingAttr) then
    NamingStrategy := NamingAttr.StrategyClass.Create
  else
    NamingStrategy := TDefaultNamingStrategy.Create;


  for RttiField in ClassType.GetFields do
    // Fields if they have an RTTI type and JsonIgnore attribute is not present.
    // All fields are included by default except JsonIgnore excluded them.
    // Also exclude fields declared in TObject
    if Assigned(RttiField.Parent) and (RttiField.Parent.Handle <> TypeInfo(TObject))
      and Assigned(RttiField.FieldType)
      and not Assigned(TRttiUtils.GetInstance.GetAttribute(RttiField, JsonIgnoreAttribute)) then
    begin
      BoundField := TJSchemaBoundField.Create(GetMemberName(RttiField, NamingStrategy), True, True);
      AFields.Add(BoundField);
      BoundField.Member := RttiField;
    end;

  for RttiProp in ClassType.GetProperties do
    // Only include properties if they have an RTTI type and JsonProperty attribute is present.
    // Properties are not included by default unless JsonProperty is present.
    if Assigned(RttiProp.Parent) and (RttiProp.Parent.Handle <> TypeInfo(TObject))
      and Assigned(RttiProp.PropertyType)
      and Assigned(TRttiUtils.GetInstance.GetAttribute(RttiProp, JsonPropertyAttribute)) then
    begin
      BoundField := TJSchemaBoundField.Create(GetMemberName(RttiProp, NamingStrategy),
        RttiProp.IsReadable, RttiProp.IsWritable);
      AFields.Add(BoundField);
      BoundField.Member := RttiProp;
    end;
end;

{ TJSchemaObjectGeneratorFactory }

function TJSchemaObjectGeneratorFactory.CreateGenerator(
  Context: TJSchemaGeneratorContext;
  const ATypeToken: TTypeToken): IJSchemaGenerator;
begin
  if ATypeToken.IsClass then
    Result := TJSchemaObjectGenerator.Create(ATypeToken.GetClass, Context.Generators)
  else
    Result := nil;
end;

{ TJSchemaBoundField }

constructor TJSchemaBoundField.Create(const AName: string; ASerialize,
  ADeserialize: Boolean);
begin
  FName := AName;
  FSerialize := ASerialize;
  FDeserialize := ADeserialize;
end;

function TJSchemaBoundField.GetMemberType: TRttiType;
begin
  Result := TRttiUtils.GetInstance.GetMemberRttiType(Member);
end;

end.
