unit Bcl.Json.ObjectConverter;

{$I bcl.inc}

interface

uses
  Generics.Collections, Rtti,
  Bcl.Json.Attributes,
  Bcl.Json.BaseObjectConverter,
  Bcl.Json.Converters,
  Bcl.Json.Reader,
  Bcl.Json.Writer;

type
  TJsonBoundField = class
  private
    FName: string;
    FMember: TRttiMember;
    FReuseValue: Boolean;
    FDeserialize: Boolean;
    FSerialize: Boolean;
    {$IFDEF AUTOREFCOUNT}[Weak]{$ENDIF}
    FConverters: TJsonConverters;
    FInclusionMode: TInclusionMode;
    function GetConverter: IJsonTypeConverter;
    function GetMemberType: TRttiType;
    function IsDefaultValue(const Value: TValue): Boolean;
  public
    constructor Create(AConverters: TJsonConverters; const AName: string; ASerialize, ADeserialize: Boolean);
    function ShouldWrite(AObject: TObject; out AValue: TValue): Boolean;
    procedure WriteJson(Writer: TJsonWriter; const Value: TValue);
    procedure ReadJson(Reader: TJsonReader; AObject: TObject);
    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;
    property ReuseValue: Boolean read FReuseValue write FReuseValue;
    property InclusionMode: TInclusionMode read FInclusionMode write FInclusionMode;
  end;

  TGetTypeNameProc = reference to procedure(AClass: TClass; var TypeName: string);
  TSolveTypeNameProc = reference to procedure(const TypeName: string; var AClass: TClass);

  TJsonObjectConverter = class(TJsonBaseObjectConverter)
  strict private
    FContext: TRttiContext;
    FBoundFields: TDictionary<TClass, TList<TJsonBoundField>>;
    FOnGetTypeName: TGetTypeNameProc;
    FOnSolveTypeName: TSolveTypeNameProc;
    procedure InternalLoadBoundFields(AClass: TClass; AFields: TList<TJsonBoundField>;
      InclusionMode: TInclusionMode; NamingStrategy: IJsonNamingStrategy);
    procedure LoadBoundFields(AClass: TClass; AFields: TList<TJsonBoundField>);
    function GetBoundFields(AClass: TClass): TList<TJsonBoundField>;
    function GetMemberName(RttiMember: TRttiMember; AStrategy: IJsonNamingStrategy): string;
  protected
    function ReadProperty(const PropName: string; AObject: TObject;
      Reader: TJsonReader): Boolean; override;
    procedure WriteProperties(AObject: TObject; Writer: TJsonWriter); override;
    function QualifiedName(AClass: TClass): string; override;
    function FindType(const AQualifiedName: string): TClass; override;
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    property OnGetTypeName: TGetTypeNameProc read FOnGetTypeName write FOnGetTypeName;
    property OnSolveTypeName: TSolveTypeNameProc read FOnSolveTypeName write FOnSolveTypeName;
  end;

  TJsonObjectConverterFactory = class(TJsonBaseObjectConverterFactory)
  public
    function CreateConverter(Converters: TJsonConverters; const ATypeToken: TTypeToken): IJsonTypeConverter; override;
  end;

implementation

uses
  TypInfo,
  Bcl.Collections,
  Bcl.Json.NamingStrategies,
  Bcl.Rtti.Utils;

{ TJsonObjectConverterFactory }

function TJsonObjectConverterFactory.CreateConverter(Converters: TJsonConverters;
  const ATypeToken: TTypeToken): IJsonTypeConverter;
begin
  if ATypeToken.IsClass then
    Result := TJsonObjectConverter.Create(ATypeToken.GetClass, Converters, Self)
  else
    Result := nil;
end;

{ TJsonObjectConverter }

procedure TJsonObjectConverter.AfterConstruction;
begin
  inherited;
  FContext := TRttiContext.Create;
  FBoundFields := TObjectDictionary<TClass, TList<TJsonBoundField>>.Create([doOwnsValues]);
end;

procedure TJsonObjectConverter.BeforeDestruction;
begin
  FContext.Free;
  FBoundFields.Free;
  inherited;
end;

function TJsonObjectConverter.FindType(const AQualifiedName: string): TClass;
var
  RttiType: TRttiType;
begin
  Result := nil;
  RttiType := FContext.FindType(AQualifiedName);
  if (RttiType <> nil) and RttiType.IsInstance then
    Result := RttiType.AsInstance.MetaclassType;
  if Assigned(FOnSolveTypeName) then
    FOnSolveTypeName(AQualifiedName, Result);
end;

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

function TJsonObjectConverter.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 TJsonObjectConverter.InternalLoadBoundFields(AClass: TClass;
  AFields: TList<TJsonBoundField>; InclusionMode: TInclusionMode;
  NamingStrategy: IJsonNamingStrategy);
var
  ClassType: TRttiType;
  RttiField: TRttiField;
  RttiProp: TRttiProperty;
  BoundField: TJsonBoundField;
  IncludeAttr: JsonIncludeAttribute;
  NamingAttr: JsonNamingStrategyAttribute;
begin
  if AClass = TObject then Exit;
  ClassType := FContext.GetType(AClass);
  if TRttiUtils.GetInstance.TryGetAttribute<JsonIncludeAttribute>(ClassType, IncludeAttr) then
    InclusionMode := IncludeAttr.InclusionMode;

  if TRttiUtils.GetInstance.TryGetAttribute<JsonNamingStrategyAttribute>(ClassType, NamingAttr) then
    NamingStrategy := NamingAttr.StrategyClass.Create;

  if AClass.ClassParent <> nil then
    InternalLoadBoundFields(AClass.ClassParent, AFields, InclusionMode, NamingStrategy);

  for RttiField in ClassType.GetDeclaredFields 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 := TJsonBoundField.Create(Converters, GetMemberName(RttiField, NamingStrategy), True, True);
      AFields.Add(BoundField);
      BoundField.Member := RttiField;
      BoundField.ReuseValue := RttiField.FieldType.IsInstance;

      if TRttiUtils.GetInstance.TryGetAttribute<JsonIncludeAttribute>(RttiField, IncludeAttr) then
        BoundField.InclusionMode := IncludeAttr.InclusionMode
      else
        BoundField.InclusionMode := InclusionMode;
    end;

  for RttiProp in ClassType.GetDeclaredProperties 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 := TJsonBoundField.Create(Converters, GetMemberName(RttiProp, NamingStrategy),
        RttiProp.IsReadable, RttiProp.IsWritable);
      AFields.Add(BoundField);
      BoundField.Member := RttiProp;
      BoundField.ReuseValue := RttiProp.PropertyType.IsInstance;

      if TRttiUtils.GetInstance.TryGetAttribute<JsonIncludeAttribute>(RttiProp, IncludeAttr) then
        BoundField.InclusionMode := IncludeAttr.InclusionMode
      else
        BoundField.InclusionMode := InclusionMode;
    end;
end;

procedure TJsonObjectConverter.LoadBoundFields(AClass: TClass;
  AFields: TList<TJsonBoundField>);
var
  NamingStrategy: IJsonNamingStrategy;
begin
  NamingStrategy := TDefaultNamingStrategy.Create;
  InternalLoadBoundFields(AClass, AFields, Factory.InclusionMode, NamingStrategy);
end;

function TJsonObjectConverter.QualifiedName(AClass: TClass): string;
begin
  {$IFDEF DELPHIXE2_LVL}
  Result := AClass.QualifiedClassName;
  {$ELSE}
  Result := AClass.UnitName + '.' + AClass.ClassName;
  {$ENDIF}
  if Assigned(FOnGetTypeName) then
    FOnGetTypeName(AClass, Result);
end;

function TJsonObjectConverter.ReadProperty(const PropName: string;
  AObject: TObject; Reader: TJsonReader): Boolean;
var
  Field: TJsonBoundField;
begin
  Result := False;
  for Field in GetBoundFields(AObject.ClassType) do
    if Field.Name = PropName then
    begin
      Result := True;
      Field.ReadJson(Reader, AObject);
    end;
end;

procedure TJsonObjectConverter.WriteProperties(AObject: TObject;
  Writer: TJsonWriter);
var
  Field: TJsonBoundField;
  Value: TValue;
begin
  for Field in GetBoundFields(AObject.ClassType) do
    if Field.ShouldWrite(AObject, Value) then
    begin
      NotifyPropertyWrite(Field.Member, Value);
      Writer.WriteName(Field.Name);
      Field.WriteJson(Writer, Value);
    end;
end;

{ TJsonBoundField }

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

function TJsonBoundField.GetConverter: IJsonTypeConverter;
begin
  Result := FConverters.Get(MemberType.Handle);
end;

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

function TJsonBoundField.IsDefaultValue(const Value: TValue): Boolean;
begin
  if Value.IsEmpty then
    Result := True
  else
    case Value.Kind of
      tkInteger,
      tkInt64,
      tkEnumeration:
        Result := Value.AsOrdinal = 0;

      tkString,
      tkLString,
      tkWString,
      tkUString:
        Result := Value.AsString = '';
      tkFloat:
        Result := Value.AsExtended = 0;
      tkDynArray,
      tkArray:
        Result := Value.GetArrayLength = 0;
      tkSet:
        Result := SetToString(Value.TypeInfo, PInteger(Value.GetReferenceToRawData)^) = '';
  //    tkRecord: ; // implement Nullable
    else
      Result := False;
    end;
end;

procedure TJsonBoundField.ReadJson(Reader: TJsonReader; AObject: TObject);
var
  OldValue, Value: TValue;
begin
  if not Deserialize then
  begin
    Reader.SkipValue;
    Exit;
  end;
  
  if ReuseValue then
  begin
    // if it's an object, get the existing value, because we will deserialize over
    // it. Later we should put a configuration here so users can choose if a specific
    // field/property should use the existing instance or create a new one to replace
    // what exists
    Value := TRttiUtils.GetInstance.GetValue(Member, AObject);
    OldValue := Value;
    GetConverter.ReadJson(Reader, Value);

    // if values are not objects, or if objects are different, then set the value.
    // Or, in other words: only leave value unchanged if both are objects and are the same object
    if not (OldValue.IsObject and Value.IsObject and (OldValue.AsObject = Value.AsObject)) then
      TRttiUtils.GetInstance.SetValue(Member, AObject, Value);
  end
  else
  begin
    Value := TValue.Empty;
    GetConverter.ReadJson(Reader, Value);
    TRttiUtils.GetInstance.SetValue(Member, AObject, Value);
  end;
end;

function TJsonBoundField.ShouldWrite(AObject: TObject;
  out AValue: TValue): Boolean;
begin
  if not Serialize then Exit(False);
  AValue := TRttiUtils.GetInstance.GetValue(Member, AObject);
  case InclusionMode of
    TInclusionMode.NonDefault:
      Result := not IsDefaultValue(AValue);
  else
    Result := True;
  end;
end;

procedure TJsonBoundField.WriteJson(Writer: TJsonWriter; const Value: TValue);
begin
  GetConverter.WriteJson(Writer, Value);
end;

end.

