XSuperJSON.pas

 (*
  *                       XSuperObject - Simple JSON Framework
  *
  * The MIT License (MIT)
  * Copyright (c) 2015 Onur YILDIZ
  *
  *
  * Permission is hereby granted, free of charge, to any person
  * obtaining a copy of this software and associated documentation
  * files (the "Software"), to deal in the Software without restriction,
  * including without limitation the rights to use, copy, modify,
  * merge, publish, distribute, sublicense, and/or sell copies of the Software,
  * and to permit persons to whom the Software is furnished to do so,
  * subject to the following conditions:
  *
  * The above copyright notice and this permission notice shall
  * be included in all copies or substantial portions of the Software.
  *
  * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
  * OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,
  * DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  * TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH
  * THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  *
  *)

unit XSuperJSON;

interface

uses
  SysUtils, Classes, Generics.Collections, Generics.Defaults, Math, DateUtils,
  {$IFDEF FPC}RegEx{$ELSE}RegularExpressions{$ENDIF}, RTTI;


const
  CNull = 'null';
  MaxCHR = #127;

  Err_UnexpectedEndOfInput = 'Unexpected end of input';
  Err_Expected = 'Expected %s';
  Err_ExpectedButFound = '"%s" expected but "%s" found';
  Err_UnexpectedTokenILLEGAL = 'Unexpected token ILLEGAL';

type

  // ## Forward Declarations
  // -----------------------

  TJSONNull = class;
  TLexGenerator = class;
  TRoute = class;
  PPosition = ^TPosition;
  TPosition = record
    Col: Integer;
    Line: Integer;
  end;

  TDataType = (dtNil, dtNull, dtObject, dtArray, dtString, dtInteger, dtFloat, dtBoolean, dtDateTime, dtDate, dtTime);
  TJSONComparison<T> = {$IFDEF FPC} function(Left, Right: T): Integer{$ELSE}reference to function(Left, Right: T): Integer{$ENDIF};
  // ## Exception

  TJSONSyntaxError = class(Exception)
  public
    constructor Create(const Msg: String; Pos: PPosition);
    constructor CreateFmt(const Msg: String; const Args: array of TVarRec; Pos: PPosition);
  end;

  // ## JSONWriter
  TJSONWriter = class
  public const
    IDENT_SIZE = 2;
  private
    FData: TStringBuilder;
    FIdent: Boolean;
    FIdentOffset: Integer;
    FUniversalTime: Boolean;
  public
    constructor Create(const useIdent, useUniversalTime: Boolean);
    destructor Destroy; override;
    procedure Inc;
    procedure Dec;

    function Append(const Value: string; const CRLF: Boolean = False): TJSONWriter; overload;
    function Append(const Value: int64; const CRLF: Boolean = False): TJSONWriter; overload;
    function AppendVal(const Value: string; const CRLF: Boolean = False): TJSONWriter; overload;
    function AppendVal(const Value: int64; const CRLF: Boolean = False): TJSONWriter; overload;
    function ToString: string; {$IFNDEF FPC}override;{$ENDIF}

    property Ident: Boolean read FIdent;
    property UniversalTime: Boolean read FUniversalTime;
  end;


  // ## JSON Symbols
  // ---------------

  IJSONAncestor = interface
  ['{FFB71762-50A1-4D27-9F59-56F6208421C7}']
    function GetAsVariant: Variant;
    procedure SetAsVariant(const Value: Variant);
    function GetDataType: TDataType;
    function GetIsNull: Boolean;
    procedure AsJSONString(Str: TJSONWriter);
    property IsNull: Boolean read GetIsNull;
    property DataType: TDataType read GetDataType;
    property AsVariant: Variant read GetAsVariant write SetAsVariant;
  end;

  TJSONAncestor = class abstract(TInterfacedObject, IJSONAncestor)
  private
    function GetAsVariant: Variant;
    procedure SetAsVariant(const Value: Variant);
  protected
    function GetDataType: TDataType; virtual;
    function GetIsNull: Boolean; virtual;
  public
    procedure AsJSONString(Str: TJSONWriter); virtual;
    property IsNull: Boolean read GetIsNull;
    property DataType: TDataType read GetDataType;
    property AsVariant: Variant read GetAsVariant write SetAsVariant;
  end;

  IJSONValue<T> = interface(IJSONAncestor)
  ['{0B1ED53C-EF62-4BFA-9E78-9DD9088D96C5}']
    function GetData: T;
    procedure SetData(const Value: T);
    procedure SetNull;
    property Value: T read GetData write SetData;
  end;

  TJSONValue<T> = class abstract(TJSONAncestor, IJSONValue<T>)
  public
    FNull: Boolean;
    FData: T;
  protected
    function GetData: T; virtual;
    procedure SetData(const Value: T); virtual;
    function GetIsNull: Boolean; override;
    property Value: T read GetData write SetData;
  public
    constructor Create(const Value: T);
    constructor CreateNull;
    procedure SetNull;
  end;

  IJSONNull = interface(IJSONValue<Boolean>)['{C19F5715-B832-46D8-8668-1A9DC31393D7}']end;
  TJSONNull = class(TJSONValue<Boolean>, IJSONNull)
  public
    procedure AsJSONString(Str: TJSONWriter); override;
  protected
    function GetIsNull: Boolean; override;
  end;

  IJSONBoolean = interface(IJSONValue<Boolean>)['{CCC8D8C5-081D-4DCF-93DB-CC0696458A12}']end;
  TJSONBoolean = class(TJSONValue<Boolean>, IJSONBoolean)
  public
    procedure AsJSONString(Str: TJSONWriter); override;
    property Value;
  end;

  IJSONString = interface(IJSONValue<String>)['{C507BB41-3674-4F47-8D6B-5605258F6A2F}']end;
  TJSONString = class(TJSONValue<String>, IJSONString)
  public
    procedure AsJSONString(Str: TJSONWriter); override;
    property Value;
  end;

  IJSONRaw = interface(IJSONString)['{EF5EF422-1A81-49EA-A3E0-9E7D5B5CC1E2}']end;
  TJSONRaw = class(TJSONString, IJSONRaw)
  public
    procedure AsJSONString(Str: TJSONWriter); override;
    property Value;
  end;

  IJSONInteger = interface(IJSONValue<Int64>)['{E9D84348-9634-40F5-8A1F-FF006F45FC6D}']end;
  TJSONInteger = class(TJSONValue<Int64>, IJSONInteger)
  public
    procedure AsJSONString(Str: TJSONWriter); override;
    property Value;
  end;

  IJSONFloat = interface(IJSONValue<Double>)['{29D840FB-191B-4304-9518-C2937B3AE6B0}']end;
  TJSONFloat = class(TJSONValue<Double>, IJSONFloat)
  public
    procedure AsJSONString(Str: TJSONWriter); override;
    property Value;
  end;

  IJSONBaseDate<T> = interface(IJSONValue<T>)
  ['{7ACB3D47-A9A6-49C1-AFF3-F451368EAE48}']
    function GetAsString: String;
    property AsString: String read GetAsString;
  end;

  TJSONBaseDate<T> = class(TJSONValue<T>, IJSONBaseDate<T>)
  protected
    FFormat: String;
  public
    function GetAsString: String;
    procedure AsJSONString(Str: TJSONWriter); override;
  end;

  IJSONDateTime = interface(IJSONBaseDate<TDateTime>)['{9441CA2E-B822-4C13-ABF0-15F8026CCE50}']end;
  TJSONDateTime = class(TJSONBaseDate<TDateTime>, IJSONDateTime)
  public
    constructor Create(const Value: TDateTime; const Format: String = 'yyyy-mm-dd"T"hh":"mm":"ss.zzz');
    property Value;
  end;

  IJSONDate = interface(IJSONBaseDate<TDate>)['{A862D6A5-2C4A-41CD-B2C0-F7B58FA14066}']end;
  TJSONDate = class(TJSONBaseDate<TDate>, IJSONDate)
  public
    constructor Create(const Value: TDate; const Format: String = 'yyyy-mm-dd');
    property Value;
  end;

  IJSONTime = interface(IJSONBaseDate<TTime>)['{EEBCD145-B837-4129-A21D-378DF7DA53B2}']end;
  TJSONTime = class(TJSONBaseDate<TTime>, IJSONTime)
  public
    constructor Create(const Value: TTime; const Format: String = 'hh":"mm":"ss.zzz');
    property Value;
  end;


  TJSONDateTimeCheckCallBack = {$IFDEF FPC} function(Str: String; var Value: TDateTime; var Typ: TDataType): Boolean{$ELSE}reference to function(Str: String; var Value: TDateTime; var Typ: TDataType): Boolean{$ENDIF};
  TJSONDateManager = class
  private
    class var FFormats: TList<TJSONDateTimeCheckCallBack>;
    class function GetFormats: TList<TJSONDateTimeCheckCallBack>; static; inline;
  public
    class constructor Create;
    class destructor Destroy;
    class function Check(const Data: String; var AValue: TDateTime; var Typ: TDataType): Boolean;
    class property Formats: TList<TJSONDateTimeCheckCallBack> read GetFormats;
  end;

  IJSONPair = interface
  ['{D328943F-5ED1-4B35-8332-573156565C96}']
    function GetName: String;
    function GetValue: IJSONAncestor;
    procedure SetName(const Value: String);
    procedure SetValue(const Value: IJSONAncestor);
    property Name: String read GetName write SetName;
    property JSONValue: IJSONAncestor read GetValue write SetValue;
  end;

  TJSONPair = class(TInterfacedObject, IJSONPair)
  private
    FName: String;
    FValue: IJSONAncestor;
    function GetName: String;
    function GetValue: IJSONAncestor;
    procedure SetName(const Value: String);
    procedure SetValue(const Value: IJSONAncestor);
  public
    constructor Create(const aName: String; aValue: IJSONAncestor);
    destructor Destroy; override;
    property Name: String read GetName write SetName;
    property JSONValue: IJSONAncestor read GetValue write SetValue;
  end;

  TJSONEnumerator<T> = record
    Index : Integer;
    List : TList<T>;
    function MoveNext : Boolean;
    function GetCurrent : T;
    property Current : T read GetCurrent;
  end;

  IJSONObject = Interface(IJSONValue<IJSONPair>)
  ['{2A9244EC-F202-4CC1-9F89-7DA12437F7ED}']
    function Count: Integer;
    function Get(const Name: String): IJSONPair; overload;
    function Get(const Index: Integer): IJSONPair; overload;
    procedure AddPair(P: IJSONPair); overload;
    procedure AddPair(Name: String; Value: IJSONAncestor); overload;
    procedure Remove(P: IJSONPair); overload;
    procedure Remove(const Name: String); overload;
    procedure Remove(const Index: Integer); overload;
    function GetEnumerator: TJSONEnumerator<IJSONPair>;
    procedure Sort(Comparison: TJSONComparison<IJSONPair>);
  end;


  TJSONObject = class(TJSONValue<IJSONPair>, IJSONObject)
  private
    FPairList: TList<IJSONPair>;
    FNull: Boolean;
  protected
    function GetIsNull: Boolean; override;
  public
    constructor Create;
    destructor Destroy; override;
    function Count: Integer;
    function Get(const Name: String): IJSONPair; overload;
    function Get(const Index: Integer): IJSONPair; overload;
    procedure AsJSONString(Str: TJSONWriter); override;
    procedure AddPair(P: IJSONPair); overload;
    procedure AddPair(Name: String; Value: IJSONAncestor); overload; inline;
    procedure Remove(P: IJSONPair); overload; inline;
    procedure Remove(const Name: String); overload;
    procedure Remove(const Index: Integer); overload;
    function GetEnumerator: TJSONEnumerator<IJSONPair>;
    procedure Sort(Comparison: TJSONComparison<IJSONPair>);
    class function ParseJSONValue(const Str: String; const CheckDate: Boolean): IJSONAncestor;
  end;

  IJSONArray = interface(IJSONValue<IJSONAncestor>)
  ['{C63B4323-6D7E-4151-BA1B-4C55CDE28FDB}']
    procedure Add(Val: IJSONAncestor);
    procedure Remove(Val: IJSONAncestor); overload;
    procedure Remove(Index: Integer); overload;
    procedure Clear;
    function Count: Integer;
    function Get(const I: Integer): IJSONAncestor;
    procedure SetIndex(const Int: Integer; const Value: IJSONAncestor);
    function GetEnumerator: TJSONEnumerator<IJSONAncestor>;
    procedure Sort(Comparison: TJSONComparison<IJSONAncestor>);
    property Index[const Int: Integer]: IJSONAncestor read Get write SetIndex; default;
  end;

  TJSONArray = class(TJSONValue<IJSONAncestor>, IJSONArray)
  private
    FList: TList<IJSONAncestor>;
    FNull: Boolean;
    procedure SetIndex(const Int: Integer; const Value: IJSONAncestor);
  protected
    function GetIsNull: Boolean; override;
  public
    constructor Create;
    destructor Destroy; override;
    procedure AsJSONString(Str: TJSONWriter); override;
    procedure Add(Val: IJSONAncestor);
    procedure Remove(Val: IJSONAncestor); overload;
    procedure Remove(Index: Integer); overload;
    procedure Clear;
    function Count: Integer;
    function Get(const I: Integer): IJSONAncestor;
    function GetEnumerator: TJSONEnumerator<IJSONAncestor>;
    procedure Sort(Comparison: TJSONComparison<IJSONAncestor>);
    property Index[const Int: Integer]: IJSONAncestor read Get write SetIndex; default;
  end;


  TJSONBuilder = class
  private
    LGen: TLexGenerator;
    FCheckDates: Boolean;
  public
    constructor Create(const JSON: String; const CheckDates: Boolean);
    destructor Destroy; override;
    function  ReadValue: IJSONAncestor;
    procedure ReadString(var Val: IJSONAncestor);
    procedure ReadInteger(var Val: IJSONAncestor);
    procedure ReadFloat(var Val: IJSONAncestor);
    procedure ReadObject(var Val: IJSONAncestor);
    procedure ReadTrue(var Val: IJSONAncestor);
    procedure ReadFalse(var Val: IJSONAncestor);
    procedure ReadNull(var Val: IJSONAncestor);
    procedure ReadArray(var Val: IJSONAncestor);
  end;

  TJSONInterpreter = class
  private
    LGen: TLexGenerator;
    FJSON: IJSONAncestor;
    FExceptionBlock: Boolean;
    function ReadName(Base: IJSONAncestor): IJSONAncestor;
    function ReadArrayIndex(Base: IJSONArray): IJSONAncestor;
    function ReadObject(Base: IJSONAncestor): IJSONObject;
    function ReadArray(Base: IJSONAncestor): IJSONArray;
    function ReadValue(Base: IJSONAncestor): IJSONAncestor;
    procedure CreateExcept(const S: String; Args: array of TVarRec); overload;
    procedure CreateExcept(const S: String); overload; inline;
  public
    constructor Create(const Expression: String; JSON: IJSONAncestor; BlockException: Boolean = False);
    destructor Destroy; override;
    function ReadExpression: IJSONAncestor;
  end;


  // ## Parse
  // --------

  TLexemType = ( ltNil,
                 ltSValue, ltIValue, ltDValue, ltNull, ltCLeft, ltCRight,
                 ltBLeft, ltBRight, ltBSlash, ltColon, ltDot, ltVirgule,
                 ltName,
                 ltTrue,
                 ltFalse );

  TLexemTypes = set of TLexemType;

  TLexBuff = class
  public
    Capacity: Integer;
    Length : Integer;
    Buff: PWideChar;
    constructor Create;
    destructor Destroy; override;
    function AsString: String; inline;
    function AsInt64: Int64;
    function AsDouble: Double;
    function AsType: TLexemType;
    function AsHInt: Int64;
    procedure Add(Ch: WideChar); inline;
    procedure Grow;
    procedure Clear; inline;
  end;

  ILexeme = ^TLexeme;
  TLexeme = record
    Pos: TPosition;
    Int: Int64;
    Str: String;
    Dbl: Double;
    LType: TLexemType;
  end;

  TParseProc = (ppNil, ppInteger, ppDouble, ppString, ppName, ppEscape, ppEscapeUChar);

  TTriggerProcs = set of (ttBuffer, ttEnd, ttBack);

  TTrigger = class
  public
    TriggerProcs: TTriggerProcs;
    ParseProcs: TParseProc;
    NextRoute: TRoute;
    BF: Boolean;
    ED: Boolean;
    BK: Boolean;
    constructor Create(NextRoute: TRoute; TriggerProcs: TTriggerProcs; ParseProcs: TParseProc);
  end;

  TErrorTrigger = class(TTrigger)
  private
    FMessage: String;
    function GetMeessage: String;
    procedure SetMessage(const Value: String);
  public
    constructor Create(const Message: String);
    property Message: String read GetMeessage write SetMessage;
  end;


  TNoRouteTrigger = class(TTrigger)
  end;

  TUseRouteTrigger = class(TTrigger)
  end;

  TJumpTrigger = class(TTrigger)
  end;

  {$WARNINGS OFF}
  TRouteChars = set of Char;
  {$WARNINGS ON}

  TRoute = class
  private
    FName: String;
    FTriggers: array[#0..MaxCHR] of TTrigger;
    FTriggerList: TObjectList<TTrigger>;
    function GetIndex(Ch: WideChar): TTrigger; inline;
    function GetName: String;
  public
    constructor Create(const Name: String);
    destructor Destroy; override;
    property Name: String read GetName;
    procedure Add(const Chars: TRouteChars; Trigger: TTrigger);
    procedure NoRoute(Trigger: TTrigger);
    function TryGetRoute(Ch: WideChar; var Trg: TTrigger): Boolean; inline;
    property Index[Ch: WideChar]: TTrigger read GetIndex; default;
  end;

  TLexGrammar = class
  private
     FRoutes: TList<TRoute>;
  protected
     function FirstRoute: TRoute; virtual; abstract;
     function CreateRoute(const Name: String): TRoute;
     function EscapeSupport: Boolean; virtual;
     function EscapeRoute: TRoute; virtual;
  public
     constructor Create; virtual;
     destructor Destroy; override;
  end;

  TJSONGrammar = class(TLexGrammar)
  private
     rFirst,
     rName,
     rString,
     rString2,
     rInt,
     rDouble,
     rExp, rExpE,
     rExpPM,

     rEscape,
     rEscapeRoute,
     rEscapeUChar: TRoute;

  protected
     function FirstRoute: TRoute; override;
     function EscapeSupport: Boolean; override;
     function EscapeRoute: TRoute; override;
  public
     constructor Create; override;
     destructor Destroy; override;
  end;

  TLexGenerator = class
  private
    FFirstRoute: TRoute;
    FBuffer: TLexBuff;
    FEscapeBuff: TLexBuff;
    FCurr: PWideChar;
    FCurrPos: PPosition;
    FLexem: ILexeme;
    FLexG: TLexGrammar;
    FEscapeSupport: Boolean;
    FEscapeRoute: TRoute;
    FExceptBlock: Boolean;
    procedure CreateLexeme;
    procedure NextLex;
    procedure KillLex; inline;
  public
    constructor Create(LexG: TLexGrammar = nil; ExceptBlock: Boolean = False);
    destructor Destroy; override;
    procedure Load(const Source: String);
    function  Check(LTyp: TLexemType): Boolean; overload;
    function  Check(LTyp: TLexemTypes): TLexemType; overload;
    function  CheckName(var S: String): Boolean;
    function  CheckKill(LTyp: TLexemType): Boolean; overload;
    function  CheckKill(LTyp: TLexemTypes): TLexemType; overload;
    function  Current: ILexeme; inline;
    property CurrPos: PPosition read FCurrPos;
  end;

  TSuperParser = class
  public
    class function ParseJSON(const S: String; const CheckDateTime: Boolean): IJSONAncestor;
  end;

  TISO8601 = record
  private
    FData: TMatch;
    FSuccess: Boolean;
    FOffset: Integer;
    FUseTime: Boolean;
    FUseDate: Boolean;
    FValue: TDateTime;
    FValueType: TDataType;
    function NextOffset: Integer;
    function GetIntData(const Index: Integer): Integer; overload; inline;
    function GetIntData(const Index: Integer; const P: Boolean): Integer; overload;
    function GetStrData(const Index: Integer): String; inline;
    procedure ReadStructure;
    procedure ReadZulu;
    function ReadDate: Boolean;
    function ReadTime: Boolean;
    procedure ReadMS;
    procedure ReadTZ(const P: Boolean);
  public
    constructor Create(const Value: String);
    property Value: TDateTime read FValue;
    property ValueType: TDataType read FValueType;
    property Success: Boolean read FSuccess;
  end;

  function LimitedStrToUTF16(const Str: String): String;

implementation

uses
  XSuperObject;

const
  FloatFormat : TFormatSettings = ( DecimalSeparator : '.' );
  STokenTypes : array [TLexemType] of string = ('Nil',
                'String', 'Integer', 'Float', 'Null', '[', ']',
                '(', ')', '\', ':', '.', ',',
                '',
                'TRUE',
                'FALSE' );


  optAll = [#0..#255];
  optWhiteSpace = [' ', #0, #9, #10, #13];

  optAlpha = ['a'..'z', 'A'..'Z', '$', '_', #127];
  optSym = ['[', ']', '{', '}', ':', ',', '"', '''', '.'];
  optNumeric = ['0'..'9'];
  optEscape = ['b', 'f', 'n', 'r', 't', 'v', '''', '"', '\'];
  optEscapeUnicode = ['u'];
  optHex = ['A'..'F', 'a'..'f'] + optNumeric;
  optStop = optWhiteSpace + optSym;

  HexMap : array [0..15] of WideChar = ('0', '1', '2', '3', '4', '5', '6',
           '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f');

var
  JSONLexGrammar: TJSONGrammar;
  function iff(const Bool: Boolean; _true, _false: Variant): Variant; inline;
  begin
    if Bool then
       Result := _true
    else
       Result := _false;
  end;

  function ChrToUTF16(const ChrCode: Integer): String; inline;
  begin
     Result := '\u' +
               HexMap[ChrCode shr 12] +
               HexMap[(ChrCode shr 8) and 15] +
               HexMap[(ChrCode shr 4) and 15] +
               HexMap[ChrCode and 15];
  end;

  function StrToUTF16(const Str: String): String;
  var
    Tmp: PWideChar;
  begin
    if Str = #0 then Exit(ChrToUtf16(0));
    Result := '';
    if Str = '' then
       Exit
    else
       Tmp := PWideChar(Pointer(Str));
    while Tmp^ <> #0 do
    begin
      case Tmp^ of
        #1..#31: case Tmp^ of
                  #8 : Result := Result + '\b';
                  #9 : Result := Result + '\t';
                  #10: Result := Result + '\n';
                  //#11: Result := Result + '\v';
                  #12: Result := Result + '\f';
                  #13: Result := Result + '\r';
               else
                  Result := Result + ChrtoUTF16(Ord(Tmp^))
               end;
        #34{"}: Result := Result + '\"';
        #92{\}: Result := Result + '\\';
        #127..#65535: Result := Result + ChrtoUTF16(Ord(Tmp^));
      else
        Result := Result + Tmp^;
      end;
      Inc(Tmp);
    end;
  end;

  function LimitedStrToUTF16(const Str: String): String;
  var
    Tmp: PWideChar;
  begin
    if Str = #0 then Exit(ChrToUtf16(0));
    Result := '';
    if Str = '' then
       Exit
    else
       Tmp := PWideChar(Pointer(Str));
    while Tmp^ <> #0 do
    begin
      case Tmp^ of
        #1..#31: case Tmp^ of
                  #8 : Result := Result + '\b';
                  #9 : Result := Result + '\t';
                  #10: Result := Result + '\n';
                  //#11: Result := Result + '\v';
                  #12: Result := Result + '\f';
                  #13: Result := Result + '\r';
               else
                  Result := Result + ChrtoUTF16(Ord(Tmp^))
               end;
      else
        Result := Result + Tmp^;
      end;
      Inc(Tmp);
    end;
  end;

{ TJSONAncestor }

procedure TJSONAncestor.AsJSONString(Str: TJSONWriter);
begin
  Str.Append('');
end;

function TJSONAncestor.GetDataType: TDataType;
begin
  with TCast.Create(Self) do
  begin
     Result := DataType;
     Free;
  end;
end;

function TJSONAncestor.GetIsNull: Boolean;
begin
  Result := Self is TJSONNull;
end;

function TJSONAncestor.GetAsVariant: Variant;
begin
  with TCast.Create(Self) do
  begin
     Result := AsVariant;
     Free;
  end;
end;

procedure TJSONAncestor.SetAsVariant(const Value: Variant);
begin
  with TCast.Create(Self) do
  begin
     AsVariant := Value;
     Free;
  end;
end;

{ TLexBuff }

procedure TLexBuff.Add(Ch: WideChar);
begin
  if Capacity = 0 then Exit;
  if (Length >=  Capacity - Length) then Grow;
  Buff[Length] := Ch;
  Inc(Length);
  Buff[Length] := #0;
end;

function TLexBuff.AsDouble: Double;
var
  Res: Extended;
begin
  Add(#0);
  {$WARNINGS OFF}
  if not TextToFloat(PWideChar(@Buff[0]), Res, fvExtended, FloatFormat)  then
  {$WARNINGS ON}
     raise EConvertError.Create('')
  else
     Result := Res;
end;

function TLexBuff.AsHInt: Int64;
var
  I, J: Integer;
begin
  I := 0;
  Result := 0;
  while I < Length do
  begin
    J := Ord(Buff[I]);
    Inc(I);
    case J of
       Ord('a')..Ord('f') :
          J := J - (Ord('a') - 10);
       Ord('A')..Ord('F') :
          J := J - (Ord('A') - 10);
       Ord('0')..Ord('9') :
          J := J - Ord('0');
    else
       Continue;
    end;
    Result := (Result shl 4) or J;
  end;
end;

function TLexBuff.AsInt64: Int64;
begin
  Result := StrToInt64(AsString);
end;

function TLexBuff.AsString: String;
begin
  SetString(Result, Buff, Length);
end;

function TLexBuff.AsType: TLexemType;
begin
  Result := ltName;
   if Length = 0 then
      Exit;

   case Buff[0] of
      '[': Result := ltCLeft;
      ']': Result := ltCRight;
      ':': Result := ltColon;
      ',': Result := ltVirgule;
      '{': Result := ltBLeft;
      '}': Result := ltBRight;
      '.': Result := ltDot;
   else
      if CompareText(STokenTypes[ltTrue], AsString) = 0 then
         Result := ltTrue
      else
      if CompareText(STokenTypes[ltFalse], AsString) = 0 then
         Result := ltFalse
      else
      if CompareText(STokenTypes[ltNull], AsString) = 0 then
         Result := ltNull
   end;
end;

procedure TLexBuff.Clear;
begin
  Length := 0;
  Buff[0] := #0;
end;

constructor TLexBuff.Create;
begin
  inherited;
  Length := 0;
  Capacity := 32;
  GetMem(Buff, Capacity * SizeOf(PWideChar));
end;

destructor TLexBuff.Destroy;
begin
  if Assigned(Buff) then
     FreeMem(Buff);
  inherited;
end;

procedure TLexBuff.Grow;
begin
   Capacity := Math.Max(Capacity * 2, Length + 8);
   ReallocMem(Buff, Capacity * SizeOf(WideChar));
end;

{ TSuperParser }

class function TSuperParser.ParseJSON(const S: String; const CheckDateTime: Boolean): IJSONAncestor;
var
  JSON: TJSONBuilder;
begin
  JSON := TJSONBuilder.Create(S, CheckDateTime);
  try
    Result := JSON.ReadValue;
  finally
    if Assigned(JSON) then
       JSON.Free;
  end;
end;

{ TTrigger }

{ TTrigger }

constructor TTrigger.Create(NextRoute: TRoute; TriggerProcs: TTriggerProcs;
  ParseProcs: TParseProc);
begin
  Self.NextRoute := NextRoute;
  Self.ParseProcs := ParseProcs;
  Self.TriggerProcs := TriggerProcs;
  BF := ttBuffer in TriggerProcs;
  ED := ttEnd in TriggerProcs;
  BK := ttBack in TriggerProcs;
end;

{ TRoute }

procedure TRoute.Add(const Chars: TRouteChars; Trigger: TTrigger);
var
  Ch: WideChar;
begin
  Ch := #0;

  if not FTriggerList.Contains(Trigger) then
     FTriggerList.Add(Trigger);

  while Ch <= MaxCHR do
  begin
     {$WARNINGS OFF}
       if Ch in Chars then {$WARNINGS ON}
         if not Assigned(FTriggers[Ch]) then
            FTriggers[Ch] := Trigger;
     Inc(Ch);
  end;
end;

constructor TRoute.Create(const Name: String);
begin
  FName := Name;
  FTriggerList := TObjectList<TTrigger>.Create;
end;


destructor TRoute.Destroy;
begin
  FTriggerList.Free;
  inherited;
end;

function TRoute.GetIndex(Ch: WideChar): TTrigger;
begin
  if Ch > MaxCHR then Ch := MaxCHR;
  Result := FTriggers[Ch];
end;

function TRoute.GetName: String;
begin
  Result := FName;
end;

procedure TRoute.NoRoute(Trigger: TTrigger);
var
  Ch: WideChar;
begin
  Ch := #0;

  if not FTriggerList.Contains(Trigger) then
     FTriggerList.Add(Trigger);

  while Ch <= MaxCHR do
  begin
     if not Assigned(FTriggers[Ch]) then
        FTriggers[Ch] := Trigger;
     Inc(Ch);
  end;
end;

function TRoute.TryGetRoute(Ch: WideChar; var Trg: TTrigger): Boolean;
begin
  if Ch > MaxCHR then Ch := MaxCHR;
  if FTriggers[Ch] <> nil then
  begin
     Result := True;
     Trg := FTriggers[Ch];
  end
  else
     Result := False;
end;

{ TLexGrammar }

constructor TLexGrammar.Create;
begin
  FRoutes := TList<TRoute>.Create;
end;

destructor TLexGrammar.Destroy;
begin
  FRoutes.Free;
  inherited;
end;

function TLexGrammar.EscapeRoute: TRoute;
begin
  Result := Nil;
end;

function TLexGrammar.EscapeSupport: Boolean;
begin
  Result := False;
end;

function TLexGrammar.CreateRoute(const Name: String): TRoute;
begin
  Result := TRoute.Create(Name);
  FRoutes.Add(Result);
end;

{ TJSONGrammar }

constructor TJSONGrammar.Create;
begin
  inherited;

  rFirst := CreateRoute('First');
  rName := CreateRoute('Name');
  rString := CreateRoute('String');
  rString2 := CreateRoute('String2');
  rInt := CreateRoute('Int');
  rDouble := CreateRoute('Double');

  rExp := CreateRoute('Exp');
  rExpE := CreateRoute('ExpE');
  rExpPM := CreateRoute('ExpPM');

  rEscape := CreateRoute('Escape');
  rEscapeRoute := CreateRoute('EscapeRoute');
  rEscapeUChar := CreateRoute('EscapeUChar');


  rEscape.Add( ['\'], TJumpTrigger.Create(rEscapeRoute, [], ppNil ));

  rEscapeRoute.Add(['u'], TJumpTrigger.Create(rEscapeUChar, [ttBuffer], ppNil));
  rEscapeRoute.NoRoute(TUseRouteTrigger.Create(rEscape, [ttBuffer, ttEnd], ppEscape));

  rEscapeUChar.Add(optHex, TUseRouteTrigger.Create(rEscapeUChar, [], ppEscapeUChar));
  rEscapeUChar.NoRoute(TErrorTrigger.Create(ERR_UnexpectedTokenILLEGAL));