unit HeaderGenerator;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, DOM, uutlGenerics, variants;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  THeaderGenerator = class(TObject)
  private type
    TStringTree = class(TObject)
    public type
      TItemList = specialize TutlList<TStringTree>;
      TItemMap  = specialize TutlMap<string, TStringTree>;
    private
      fLinesBefore: TStringList;
      fLinesAfter: TStringList;
      fItemList: TItemList;
      fItemMap: TItemMap;

      function GetItem(const aName: String): TStringTree;
      function GetItemCount: Integer;
      function GetItemsByIndex(const aIndex: Integer): TStringTree;
      function GetLinesAfter: TStrings;
      function GetLinesBefore: TStrings;
      function GetText: String;
    public
      property Text:                        String      read GetText;
      property LinesBefore:                 TStrings    read GetLinesBefore;
      property LinesAfter:                  TStrings    read GetLinesAfter;
      property ItemCount:                   Integer     read GetItemCount;

      property Items       [const aName: String]:   TStringTree read GetItem;
      property ItemsByIndex[const aIndex: Integer]: TStringTree read GetItemsByIndex;

      function IndexOf(const aItem: TStringTree): Integer;
      function GetOrCreateItem(const aName: String): TStringTree;
      function CreateItemAt(const aName: String; const aIndex: Integer): TStringTree;
      function DestroyItem(const aName: String): Boolean;
      procedure Clear;

      constructor Create;
      destructor Destroy; override;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkObjectType = (
      otUnknown,
      otType,
      otHandle,
      otEnum,
      otConst,
      otFuncPtr,
      otStruct,
      otCommand);
    TvkObjectTypes = set of TvkObjectType;

    TvkObject = class;
    TvkObjectList = class(specialize TutlList<TvkObject>)
    public
      function IndexOfObj(const aName: DOMstring; const aTypes: TvkObjectTypes): Integer;
      function FindObj(const aName: DOMstring; const aTypes: TvkObjectTypes; out aObject): Boolean;
      function GetPascalName(const aName: DOMString; const aPointer: Integer; const aArrSize: WideString = ''): WideString;
      function GenerateCode(const aName: String; const aCode: TStringTree): Boolean;
      procedure AddObject(const aObj: TvkObject);
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkObject = class(TObject)
    private
      fType: TvkObjectType;
      fName: DOMString;
      fComment: DOMString;
      fList: TvkObjectList;
    protected
      function GetDependencyOrder: Integer; virtual;
      procedure GenPascalName(var aName: WideString; const aPointer: Integer; const aArrSize: WideString); virtual;

      {%H-}constructor Create(const aType: TvkObjectType);
    public
      property VkType:  TvkObjectType read fType;
      property Name:    DOMString     read fName    write fName;
      property Comment: DOMString     read fComment write fComment;
      property List:    TvkObjectList read fList    write fList;

      function GetPascalName(const aPointer: Integer; const aArrSize: WideString): WideString;
      procedure ReadXml(const xml: TDOMNode); virtual;
      procedure GenerateCode(const aCode: TStringTree); virtual;
    public
      class procedure CreateFromXml(const xml: TDOMNode; const aList: TvkObjectList);
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkTypeBase = class(TvkObject)
    private
      fParent: DOMString;
      fAlias: DOMString;
    protected
      function GetDependencyOrder: Integer; override;
      procedure GenPascalName(var aName: WideString; const aPointer: Integer; const aArrSize: WideString); override;
    public
      property Parent: DOMString read fParent write fParent;
      property Alias:  DOMString read fAlias  write fAlias;

      procedure GenerateCode(const aCode: TStringTree); override;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkType = class(TvkTypeBase)
    public
      procedure ReadXml(const xml: TDOMNode); override;
      constructor Create;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkHandle = class(TvkTypeBase)
    public
      procedure ReadXml(const xml: TDOMNode); override;
      constructor Create;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkFunctionBase = class(TvkObject)
    private type
      TArgument = class(TObject)
        Typ: DOMString;
        Name: DOMString;
        IsPointer: Integer;
        IsConst: Boolean;
      end;
      TArgumentList = specialize TutlList<TArgument>;
    private
      fReturnValue: TArgument;
      fArguments: TArgumentList;
    protected
      function GetDependencyOrder: Integer; override;
      procedure GenPascalName(var aName: WideString; const aPointer: Integer; const aArrSize: WideString); override;

      procedure GenerateFunctionPtr(const aCode, aSub: TStringTree);

      {%H-}constructor Create(const aType: TvkObjectType);
    public
      property ReturnValue: TArgument     read fReturnValue;
      property Arguments:   TArgumentList read fArguments;

      destructor Destroy; override;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkFunctionPtr = class(TvkFunctionBase)
    public
      procedure ReadXml(const xml: TDOMNode); override;
      procedure GenerateCode(const aCode: TStringTree); override;
      constructor Create;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkCommand = class(TvkFunctionBase)
    public
      procedure ReadXml(const xml: TDOMNode); override;
      procedure GenerateCode(const aCode: TStringTree); override;
      constructor Create;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkStruct = class(TvkObject)
    private type
      TMember = class(TObject)
        Typ: DOMString;
        Name: DOMString;
        ArrSize: DOMString;
        IsPointer: Integer;
        IsConst: Boolean;
      end;
      TMemberList = specialize TutlList<TMember>;
    private
      fIsUnion: Boolean;
      fMember: TMemberList;
    protected
      function GetDependencyOrder: Integer; override;
      procedure GenPascalName(var aName: WideString; const aPointer: Integer; const aArrSize: WideString); override;
    public
      property Member: TMemberList read fMember;
      property IsUnion: Boolean read fIsUnion write fIsUnion;

      procedure ReadXml(const xml: TDOMNode); override;
      procedure GenerateCode(const aCode: TStringTree); override;

      constructor Create;
      destructor Destroy; override;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkEnum = class(TvkObject)
    private type
      TValue = class(TObject)
        Name: DOMString;
        Value: Variant;
        IsBit: Boolean;
      end;
      TValueList = specialize TutlList<TValue>;
    private
      fExpands: DOMString;
      fValues: TValueList;
    protected
      procedure GenPascalName(var aName: WideString; const aPointer: Integer; const aArrSize: WideString); override;
    public
      property Expands: DOMString read fExpands write fExpands;
      property Values: TValueList read fValues;
      procedure ReadXml(const xml: TDOMNode); override;
      procedure GenerateCode(const aCode: TStringTree); override;

      constructor Create;
      destructor Destroy; override;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkConst = class(TvkObject)
    private
      fValue: Variant;
    public
      property Value: Variant read fValue write fValue;
      procedure GenerateCode(const aCode: TStringTree); override;
      constructor Create;
    end;

  private const
    VK_OBJECT_TYPES: TvkObjectTypes = [ otType, otHandle, otFuncPtr, otStruct, otEnum ];
    VK_OBJECT_ALL:   TvkObjectTypes = [ low(TvkObjectType) .. high(TvkObjectType) ];

  private
    fDocument: TXMLDocument;
    fObjects: TvkObjectList;
    fComment: WideString;

  public
    procedure ReadFile(const aFilename: String);
    procedure ReadFile(const aStream: TStream);
    procedure GenerateCode(const aName: WideString; const aTemplate: String; const aOutput: String);

    procedure Clear;

    constructor Create;
    destructor Destroy; override;
  end;

implementation

uses
  Math, XMLRead, RegExpr;

type
  XmlException = class(Exception)
  public
    xml: TDOMNode;
    constructor Create(const aMsg: WideString; const aXml: TDOMNode);
  end;

const
  KEYWORD_INTF        = 'INTERFACE';
  KEYWORD_CONST       = 'CONST';
  KEYWORD_TYPES       = 'TYPES';
  KEYWORD_ENUM        = 'ENUM';
  KEYWORD_ENUM_VALUES = 'ENUM_VALUES';
  KEYWORD_STRUCT      = 'STRUCT';
  KEYWORD_FUNCPTR     = 'FUNCPTR';
  KEYWORD_COMMAND     = 'COMMAND';
  KEYWORD_IMPL        = 'IMPLEMENTATION';
  KEYWORD_COMMENT     = 'COMMENT';
  KEYWORD_VAR         = 'VAR';
  KEYWORD_CODE        = 'CODE';

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function PointerCount(const aStr: AnsiString): Integer;
var i: Integer;
begin
  result := 0;
  i := Length(aStr);
  while (i > 0) do begin
    if (aStr[i] = '*') then
      inc(result);
    dec(i);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function StrToValue(s: String): Variant;
var
  f: TFormatSettings;
  rx: TRegExpr;
begin
  f.DecimalSeparator := '.';
  rx := TRegExpr.Create;
  try
    result := Unassigned;

    rx.Expression := '^-?([0-9]+)$';
    if rx.Exec(s) then
      result := StrToInt(rx.Match[0]);

    rx.Expression := '^0x([0-9A-Fa-f]+)$';
    if rx.Exec(s) then
      result := '$' + rx.Match[1];

    rx.Expression := '^([0-9\.]+)(f|d)?$';
    if rx.Exec(s) then begin
      result := StrToFloat(rx.Match[1], f);
      if (rx.Match[2] = 'd') then
        result := Double(result);
    end;

    rx.Expression := '^\(~0U([L]*)\)$';
    if rx.Exec(s) then begin
      if (rx.Match[2] = '')
        then result := '$' + IntToHex(High(UInt32), 2 * sizeof(UInt32))
        else result := '$' + IntToHex(High(UInt64), 2 * sizeof(UInt64));
    end;
  finally
    FreeAndNil(rx);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function PrepareName(const aName, aType: WideString): WideString;
var
  rx: TRegExpr;
  s: WideString;
begin
  result := aName;
  s := '';
  if (result = 'type') then
    s := 'Type'
  else if (result = 'object') then
    s := 'Object';

  if (s <> '') then begin
    rx := TRegExpr.Create('^(T|P)?(Vk)?(.)');
    try
      if rx.Exec(String(aType))
        then result := WideString(LowerCase(rx.Match[3]) + s)
        else result := 'm' + s;
    finally
      FreeAndNil(rx);
    end;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function FormatType(const aType: THeaderGenerator.TvkObjectType): WideString;
begin
  case aType of
    otType:    result := 'TYPE';
    otHandle:  result := 'HANDLE';
    otFuncPtr: result := 'FUNCPTR';
    otStruct:  result := 'STRUCT';
    otEnum:    result := 'ENUM';
    otConst:   result := 'CONSTANT';
    otCommand: result := 'COMMAND';
  else
    result := '';
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure WriteResolveWarning(const aName: DOMString);
begin
  WriteLn('WARNING! unable to resolve identifier: ' + aName);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function GetNodeValue(xml: TDOMNode; const aName: WideString): DOMString;
var x: TDOMNode;
begin
  x := xml.FindNode(aName);
  if not Assigned(x) then
    raise XmlException.Create(xml.NodeName + ' without child ''' + aName + '''', xml);
  result := x.TextContent;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TryGetNodeValue(xml: TDOMNode; const aName: WideString; out aValue: DOMString): Boolean;
var x: TDOMNode;
begin
  x := xml.FindNode(aName);
  result := Assigned(x);
  if result then
    aValue := x.TextContent;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function GetNodeValue(xml: TDOMNode; const aName: WideString; const aDefault: DOMString): DOMString;
var x: TDOMNode;
begin
  x := xml.FindNode(aName);
  if not Assigned(x)
    then result := aDefault
    else result := x.TextContent;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function GetNodeAttrib(xml: TDOMNode; const aName: WideString): DOMString;
var x: TDOMNode;
begin
  if xml.HasAttributes then begin
    x := xml.Attributes.GetNamedItem(aName);
    if Assigned(x) then begin
      result := x.TextContent;
      exit;
    end;
  end;
  raise XmlException.Create(xml.NodeName + ' without ''' + aName + ''' attribute', xml);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function TryGetNodeAttrib(xml: TDOMNode; const aName: WideString; out aValue: DOMString): Boolean;
var x: TDOMNode;
begin
  result := true;
  if xml.HasAttributes then begin
    x := xml.Attributes.GetNamedItem(aName);
    if Assigned(x) then begin
      aValue := x.TextContent;
      exit;
    end;
  end;
  result := false;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function GetNodeAttrib(xml: TDOMNode; const aName: WideString; const aDefault: DOMString): DOMString;
var x: TDOMNode;
begin
  result := aDefault;
  if xml.HasAttributes then begin
    x := xml.Attributes.GetNamedItem(aName);
    if Assigned(x) then
      result := x.TextContent;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//XmlException//////////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor XmlException.Create(const aMsg: WideString; const aXml: TDOMNode);
begin
  inherited Create(String(aMsg + ': ' + aXml.TextContent));
  xml := aXml;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TStringTree//////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TStringTree.GetLinesAfter: TStrings;
begin
  result := fLinesAfter;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TStringTree.GetLinesBefore: TStrings;
begin
  result := fLinesBefore;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TStringTree.GetItem(const aName: String): TStringTree;
begin
  result := fItemMap[aName];
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TStringTree.GetItemCount: Integer;
begin
  result := fItemList.Count;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TStringTree.GetItemsByIndex(const aIndex: Integer): TStringTree;
begin
  result := fItemList[aIndex];
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TStringTree.GetText: String;
var
  i: Integer;
  s: String;

  procedure AddText(const aText: String; const aCanAddEmpty: Boolean);
  begin
    if not aCanAddEmpty and (aText = '') then
      exit;
    result := result + aText + sLineBreak;
  end;

begin
  result := '';
  for i := 0 to fLinesBefore.Count-1 do
    AddText(fLinesBefore[i], true);
  for i := 0 to fItemList.Count-1 do begin
    s := fItemList[i].Text;
    if (UpperCase(Trim(s)) = '{$ENDIF}') then
      result := TrimRight(result) + sLineBreak;
    AddText(s, false);
  end;
  for i := 0 to fLinesAfter.Count-1 do
    AddText(fLinesAfter[i], true);
  result := copy(result, 0, Length(result) - Length(sLineBreak));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TStringTree.IndexOf(const aItem: TStringTree): Integer;
begin
  result := fItemList.IndexOf(aItem);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TStringTree.GetOrCreateItem(const aName: String): TStringTree;
begin
  result := GetItem(aName);
  if not Assigned(result) then begin
    result := TStringTree.Create;
    fItemMap.Add(aName, result);
    fItemList.Add(result);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TStringTree.CreateItemAt(const aName: String; const aIndex: Integer): TStringTree;
begin
  result := TStringTree.Create;
  fItemMap.Add(aName, result);
  fItemList.Insert(aIndex, result);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TStringTree.DestroyItem(const aName: String): Boolean;
var t: TStringTree;
begin
  t := GetItem(aName);
  result := Assigned(t);
  if result then begin
    fItemList.Remove(t);
    fItemMap.Delete(aName);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TStringTree.Clear;
begin
  fItemList.Clear;
  fItemMap.Clear;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor THeaderGenerator.TStringTree.Create;
begin
  inherited Create;
  fLinesBefore := TStringList.Create;
  fLinesAfter  := TStringList.Create;
  fItemList    := TItemList.Create(false);
  fItemMap     := TItemMap.Create(true);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor THeaderGenerator.TStringTree.Destroy;
begin
  FreeAndNil(fItemList);
  FreeAndNil(fItemMap);
  FreeAndNil(fLinesBefore);
  FreeAndNil(fLinesAfter);
  inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkObjectList////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TvkObjectList.IndexOfObj(const aName: DOMstring; const aTypes: TvkObjectTypes): Integer;
var o: TvkObject;
begin
  if (aName = '') then
    raise Exception.Create('empty name');

  for result := 0 to Count-1 do begin
    o := GetItem(result);
    if (o.VkType in aTypes) and (o.Name = aName) then
      exit;
  end;
  result := -1;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TvkObjectList.FindObj(const aName: DOMstring; const aTypes: TvkObjectTypes; out aObject): Boolean;
var i: Integer;
begin
  i := IndexOfObj(aName, aTypes);
  result := (i >= 0);
  if result
    then TvkObject(aObject) := GetItem(i)
    else TvkObject(aObject) := nil;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TvkObjectList.GetPascalName(const aName: DOMString; const aPointer: Integer;
  const aArrSize: WideString): WideString;
var o: TvkObject;
begin
  if FindObj(aName, VK_OBJECT_TYPES, o)
    then result := o.GetPascalName(aPointer, aArrSize)
    else result := aName;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TvkObjectList.GenerateCode(const aName: String; const aCode: TStringTree): Boolean;
var o: TvkObject;
begin
  result := FindObj(aName, VK_OBJECT_ALL, o);
  if result then
    o.GenerateCode(aCode);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkObjectList.AddObject(const aObj: TvkObject);
begin
  if Assigned(aObj) then begin
    Add(aObj);
    aObj.List := self;
    WriteLn(Format('  %-10s%s', [FormatType(aObj.VkType), aObj.Name]));
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkObject////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TvkObject.GetDependencyOrder: Integer;
begin
  result := 0;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkObject.GenPascalName(var aName: WideString; const aPointer: Integer; const aArrSize: WideString);
var
  i: Integer;
begin
  if (aName = '') then begin
    aName := fName;
    if (aName = 'void') then
      aName := 'VkVoid';
    for i := 0 to aPointer-1 do
      aName := 'P' + aName;
  end;
  if (aName = 'VkVoid') then
    raise Exception.Create('void can not be used as type');
  if (aArrSize <> '') then begin
    if TryStrToInt(String(aArrSize), i)
      then aName := WideString(Format('array[0..%d] of %s', [i, aName]))
      else aName := WideString(Format('array[0..%s-1] of %s', [aArrSize, aName]));
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor THeaderGenerator.TvkObject.Create(const aType: TvkObjectType);
begin
  inherited Create;
  fType := aType;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TvkObject.GetPascalName(const aPointer: Integer; const aArrSize: WideString): WideString;
begin
  result := '';
  GenPascalName(result, aPointer, aArrSize);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkObject.ReadXml(const xml: TDOMNode);
begin
  // DUMMY
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkObject.GenerateCode(const aCode: TStringTree);
begin
  // DUMMY
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class procedure THeaderGenerator.TvkObject.CreateFromXml(const xml: TDOMNode; const aList: TvkObjectList);
var
  s, n: DOMString;

  procedure GenerateVersionEnum;
  var
    c: TvkConst;
    rx: TRegExpr;
  begin
    rx := TRegExpr.Create('\(\s*(\d+)\s*,\s*(\d+)\s*,\s*(\d+)\s*\)');
    try
      if not rx.Exec(String(xml.TextContent)) then
        raise XmlException.Create('VK_API_VERSION with malformed version', xml);

      c := TvkConst.Create;
      try
        c.Name  := 'VK_API_VERSION';
        c.Value := (StrToInt(rx.Match[1]) shl 22) or
                   (StrToInt(rx.Match[2]) shl 12) or
                   (StrToInt(rx.Match[3]) shl  0);
        aList.AddObject(c);
      except
        FreeAndNil(c);
        raise
      end;

      c := TvkConst.Create;
      try
        c.Name  := 'VK_API_VERSION_MAJOR';
        c.Value := StrToInt(rx.Match[1]);
        aList.AddObject(c);
      except
        FreeAndNil(c);
        raise
      end;

      c := TvkConst.Create;
      try
        c.Name  := 'VK_API_VERSION_MINOR';
        c.Value := StrToInt(rx.Match[2]);
        aList.AddObject(c);
      except
        FreeAndNil(c);
        raise
      end;

      c := TvkConst.Create;
      try
        c.Name  := 'VK_API_VERSION_BUGFIX';
        c.Value := StrToInt(rx.Match[3]);
        aList.AddObject(c);
      except
        FreeAndNil(c);
        raise
      end;
    finally
      FreeAndNil(rx);
    end;
  end;

  procedure GenerateConstants;
  var
    x: TDOMNode;
    c: TvkConst;
  begin
    x := xml.FirstChild;
    while Assigned(x) do begin
      if (x.NodeName = 'enum') then begin
        c := TvkConst.Create;
        try
          c.Name  := GetNodeAttrib(x, 'name');
          c.Value := StrToValue(String(GetNodeAttrib(x, 'value')));
          if (c.Value = Unassigned) then
            raise Exception.Create('Invalid constant value: ' + GetNodeAttrib(x, 'value'));
          aList.AddObject(c);
        except
          FreeAndNil(c);
          raise;
        end;
      end;
      x := x.NextSibling;
    end;
  end;

var
  obj: TvkObject;
begin
  try
    obj := nil;
    if (xml.NodeName = 'type') and TryGetNodeAttrib(xml, 'category', s) then begin
      if (s = 'basetype') or (s = 'bitmask') then
        obj := TvkType.Create
      else if (s = 'handle') then
        obj := TvkHandle.Create
      else if (s = 'funcpointer') then
        obj := TvkFunctionPtr.Create
      else if (s = 'struct') or (s = 'union') then
        obj := TvkStruct.Create
      else if (s = 'define') and TryGetNodeValue(xml, 'name', n) and (n = 'VK_API_VERSION') then
        GenerateVersionEnum;
    end else if (xml.NodeName = 'command') then
      obj := TvkCommand.Create
    else if (xml.NodeName = 'enums') then begin
      if not TryGetNodeAttrib(xml, 'type', s) then
        GenerateConstants
      else if (s = 'enum') or (s = 'bitmask') then
        obj := TvkEnum.Create;
    end;

    if Assigned(obj) then begin
      obj.ReadXml(xml);
      aList.AddObject(obj);
    end;
  except
    FreeAndNil(obj);
    raise;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkTypeBase//////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TvkTypeBase.GetDependencyOrder: Integer;
begin
  result := inherited GetDependencyOrder;
  if Assigned(List) and (fParent <> '') then
    result := max(result, List.IndexOfObj(fParent, VK_OBJECT_TYPES) + 1);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkTypeBase.GenPascalName(var aName: WideString; const aPointer: Integer; const aArrSize: WideString);
var i: Integer;
begin
  if (fAlias <> '')
    then aName := fAlias
    else aName := fName;
  if (aName = 'void') then
    aName := 'VkVoid';
  for i := 0 to aPointer-1 do
    aName := 'P' + aName;
  if (aName = 'VkVoid') then
    raise Exception.Create('void can not be used as type');
  inherited GenPascalName(aName, aPointer, aArrSize);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkTypeBase.GenerateCode(const aCode: TStringTree);
var st: TStringTree;
begin
  inherited GenerateCode(aCode);

  if Assigned(fList) and (fParent <> '') then
    fList.GenerateCode(fParent, aCode);
  if Assigned(fList) and (fAlias <> '') then
    fList.GenerateCode(fAlias, aCode);

  st := aCode.GetOrCreateItem(KEYWORD_INTF).GetOrCreateItem(KEYWORD_TYPES);
  if (st.LinesBefore.Count = 0) then
    st.LinesBefore.Add('type { simple types }');
  st := st.GetOrCreateItem(fName);
  if (st.LinesBefore.Count = 0) and (fParent <> '') and Assigned(List) then begin
    st.LinesBefore.Add(Format('  %-62s = %s;', [ fName, List.GetPascalName(fParent, 0) ]));
    st.LinesBefore.Add(Format('  P%-61s = ^%0:s;', [ fName ]));
    st.LinesBefore.Add(Format('  PP%-60s = ^P%0:s;', [ fName ]));
    st.LinesBefore.Add('');
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkType//////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkType.ReadXml(const xml: TDOMNode);
begin
  inherited ReadXml(xml);
  Name   := GetNodeValue(xml, 'name');
  Parent := GetNodeValue(xml, 'type');
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor THeaderGenerator.TvkType.Create;
begin
  inherited Create(otType);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkHandle////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor THeaderGenerator.TvkHandle.Create;
begin
  inherited Create(otHandle);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkHandle.ReadXml(const xml: TDOMNode);
begin
  inherited ReadXml(xml);
  Name   := GetNodeValue (xml, 'name');
  //Parent := GetNodeAttrib(xml, 'parent', 'VkHandle');
  Parent := 'VkHandle';
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TvkFunctionBase.GetDependencyOrder: Integer;
var a: TArgument;
begin
  result := inherited GetDependencyOrder;
  if not Assigned(List) then
    exit;
  for a in fArguments do
    result := max(result, List.IndexOfObj(a.Typ, VK_OBJECT_TYPES));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkFunctionBase.GenPascalName(var aName: WideString; const aPointer: Integer;
  const aArrSize: WideString);
var rx: TRegExpr;
begin
  if (aPointer > 0) then
    Exception.Create('function pointer can not be used as pointer type');
  if (aArrSize <> '') then
    Exception.Create('function pointer can not be used as array type');

  rx := TRegExpr.Create('PFN_([-_A-Za-z0-9]+)');
  try
    if rx.Exec(String(fName))
      then aName := 'T' + WideString(rx.Match[1])
      else aName := 'T' + fName;
  finally
    FreeAndNil(rx);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkFunctionBase.GenerateFunctionPtr(const aCode, aSub: TStringTree);
var
  st: TStringTree;
  i: Integer;
  s: WideString;
  a: TArgument;
begin
  if Assigned(fList) then begin
    fList.GenerateCode(fReturnValue.Typ, aCode);
    for a in fArguments do
      fList.GenerateCode(a.Typ, aCode);
  end;

  st := aSub.GetOrCreateItem(GetPascalName(0, ''));
  if (st.LinesBefore.Count = 0) then begin
    // head
    s := WideString(Format('  %s', [ GetPascalName(0, '') ]));
    if (ReturnValue.Typ = 'void') and (ReturnValue.IsPointer = 0)
      then s := s + ' = procedure('
      else s := s + ' = function (';
    st.LinesBefore.Add(s);

    // params
    for i := 0 to fArguments.Count-1 do begin
      s := '    ';
      a := fArguments[i];
      if a.IsConst
        then s := s + 'const '
        else s := s + '      ';
      s := s + Format('%-30s%s', [ PrepareName(a.Name, a.Typ)+':', List.GetPascalName(a.Typ, a.IsPointer) ]);
      if (i < fArguments.Count-1) then
        s := s + '; ';
      st.LinesBefore.Add(s);
    end;

    // result
    s := '  )';
    if (ReturnValue.Typ <> 'void') or (ReturnValue.IsPointer > 0) then
      s := s + ': ' + List.GetPascalName(ReturnValue.Typ, ReturnValue.IsPointer);
    s := s + '; {$IFDEF VK_CDECL}cdecl{$ELSE}stdcall{$ENDIF};';
    st.LinesBefore.Add(s);
    st.LinesBefore.Add('');
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor THeaderGenerator.TvkFunctionBase.Create(const aType: TvkObjectType);
begin
  inherited Create(aType);
  fReturnValue := TArgument.Create;
  fArguments   := TArgumentList.Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor THeaderGenerator.TvkFunctionBase.Destroy;
begin
  FreeAndNil(fReturnValue);
  FreeAndNil(fArguments);
  inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkFunctionPtr///////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkFunctionPtr.ReadXml(const xml: TDOMNode);
var
  x, p: TDOMNode;
  a: TArgument;
  rx: TRegExpr;
begin
  x := xml.FindNode('name');
  if not Assigned(x) then
    raise XmlException.Create(xml.NodeName + ' witout child ''name''', xml);
  Name := x.TextContent;

  p := x.PreviousSibling;
  if not Assigned(p) then
    raise XmlException.Create(xml.NodeName + ' witout return type', xml);

  rx := TRegExpr.Create('typedef\s+((const)?)\s*([-_A-Za-z0-9\s]+?)\s*((\*\s*(const)?\s*)*)\s*\(');
  try
    if not rx.Exec(String(p.TextContent)) then
      raise XmlException.Create('unable to parse return type of function pointer', xml);

    ReturnValue.IsConst   := (Trim(rx.Match[1]) = 'const');
    ReturnValue.Typ       := WideString(Trim(rx.Match[3]));
    ReturnValue.IsPointer := PointerCount(Trim(rx.Match[4]));

    x := xml.FirstChild;
    while Assigned(x) do begin
      if (x.NodeName = 'type') then begin
        a := TArgument.Create;
        try
          p := x.PreviousSibling;
          if not Assigned(p) then
            raise XmlException.Create('unable to parse function pointer arguments', xml);
          rx.Expression := '[A-Za-z]*';
          a.IsConst := rx.Exec(String(p.TextContent)) and (rx.Match[0] = 'const');
          a.Typ     := x.TextContent;

          p := x.NextSibling;
          if not Assigned(p) then
            raise XmlException.Create('unable to parse function pointer arguments', xml);
          rx.Expression := '((\*\s*(const)?\s*)*)\s*([-_A-Za-z0-9]+)';
          if not rx.Exec(String(p.TextContent)) then
            raise XmlException.Create('unable to parse function pointer arguments', xml);

          a.IsPointer := PointerCount((rx.Match[1]));
          a.Name      := WideString(Trim(rx.Match[4]));
          Arguments.Add(a);
        except
          FreeAndNil(a)
        end;
      end;
      x := x.NextSibling;
    end;
  finally
    FreeAndNil(rx);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkFunctionPtr.GenerateCode(const aCode: TStringTree);
var st: TStringTree;
begin
  inherited GenerateCode(aCode);
  st := aCode.GetOrCreateItem(KEYWORD_INTF).GetOrCreateItem(KEYWORD_FUNCPTR);
  if (st.LinesBefore.Count = 0) then
    st.LinesBefore.Add('type { function pointers }');
  GenerateFunctionPtr(aCode, st);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor THeaderGenerator.TvkFunctionPtr.Create;
begin
  inherited Create(otFuncPtr);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkCommand///////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkCommand.ReadXml(const xml: TDOMNode);

  procedure ParseProto(const x: TDOMNode);
  begin
    Name := GetNodeValue(x, 'name');
    ReturnValue.Typ := GetNodeValue(x, 'type');
  end;

  procedure ParseParam(const x: TDOMNode);
  var
    p: TDOMNode;
    a: TArgument;
    rx: TRegExpr;
  begin
    a := TArgument.Create;
    rx := TRegExpr.Create;
    try try
      p := x.FindNode('name');
      if not Assigned(p) then
        raise XmlException.Create('unable to parse command; param without name', xml);
      a.Name := p.TextContent;

      p := x.FindNode('type');
      if not Assigned(p) then
        raise XmlException.Create('unable to parse command; param without type', xml);
      a.Typ       := p.TextContent;
      a.IsConst   := Assigned(p.PreviousSibling) and (Trim(p.PreviousSibling.TextContent) = 'const');

      rx.Expression := '((\*\s*(const)?\s*)*)';
      if Assigned(p.NextSibling) and rx.Exec(String(p.NextSibling.TextContent)) then
        a.IsPointer := PointerCount(rx.Match[0]);
      Arguments.Add(a);
    finally
      FreeAndNil(rx);
    end;
    except
      FreeAndNil(a);
      raise;
    end;
  end;

var
  x: TDOMNode;
begin
  inherited ReadXml(xml);
  x := xml.FirstChild;
  while Assigned(x) do begin
    if (x.NodeName = 'proto') then
      ParseProto(x)
    else if (x.NodeName = 'param') then
      ParseParam(x);
    x := x.NextSibling;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkCommand.GenerateCode(const aCode: TStringTree);
var st: TStringTree;
begin
  inherited GenerateCode(aCode);
  st := aCode.GetOrCreateItem(KEYWORD_INTF).GetOrCreateItem(KEYWORD_COMMAND);
  if (st.LinesBefore.Count = 0) then
    st.LinesBefore.Add('type { commands }');
  GenerateFunctionPtr(aCode, st);

  st := aCode.GetOrCreateItem(KEYWORD_INTF).GetOrCreateItem(KEYWORD_VAR);
  if (st.LinesBefore.Count = 0) then
    st.LinesBefore.Add('var');

  st := st.GetOrCreateItem(fName);
  if (st.LinesBefore.Count = 0) then
    st.LinesBefore.Add(Format('  %-50s%s;', [fName + ':', GetPascalName(0, '')]));

  st := aCode.GetOrCreateItem(KEYWORD_IMPL).GetOrCreateItem(KEYWORD_CODE).GetOrCreateItem(fName);
  if (st.LinesBefore.Count = 0) then
    st.LinesBefore.Add(Format('  %-50s := T%0:-50s(vkGetProcAddress(%-50saInstance));', [fName, '''' + fName + ''',']));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor THeaderGenerator.TvkCommand.Create;
begin
  inherited Create(otCommand);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkStruct////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TvkStruct.GetDependencyOrder: Integer;
var
  m: TMember;
begin
  result := inherited GetDependencyOrder;
  if not Assigned(List) then
    exit;
  for m in fMember do
    result := max(result, List.IndexOfObj(m.Typ, VK_OBJECT_TYPES) + 1);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkStruct.GenPascalName(var aName: WideString; const aPointer: Integer; const aArrSize: WideString);
var i: Integer;
begin
  if (aPointer > 0) then begin
    aName := fName;
    for i := 0 to aPointer-1 do
      aName := 'P' + aName;
  end else
    aName := 'T' + fName;
  inherited GenPascalName(aName, aPointer, aArrSize);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkStruct.ReadXml(const xml: TDOMNode);
var
  x, p: TDOMNode;
  m: TMember;
  rx: TRegExpr;
begin
  Name    := GetNodeAttrib(xml, 'name');
  IsUnion := (GetNodeAttrib(xml, 'category') = 'union');

  x := xml.FirstChild;
  while Assigned(x) do begin
    if (x.NodeName = 'member') then begin
      m := TMember.Create;
      rx := TRegExpr.Create('');
      try try
        // read name
        p := x.FindNode('name');
        if not Assigned(p) then
          raise XmlException.Create('struct member without name', xml);
        m.Name := p.TextContent;
        p := p.NextSibling;
        while Assigned(p) do begin
          m.Name := m.Name + p.TextContent;
          p := p.NextSibling;
        end;
        m.Name := Trim(m.Name);

        rx.Expression := '([-_A-Za-z0-9]+)\s*\[\s*([-_A-Za-z0-9]+)\s*\]';
        if rx.Exec(String(m.Name)) then begin
          m.Name := WideString(rx.Match[1]);
          m.ArrSize := WideString(rx.Match[2]);
        end;

        // read type
        p := x.FindNode('type');
        if not Assigned(p) then
          raise XmlException.Create('struct member without type', xml);
        m.Typ       := p.TextContent;
        m.IsConst   := Assigned(p.PreviousSibling) and (Trim(p.PreviousSibling.TextContent) = 'const');
        rx.Expression := '((\*\s*(const)?\s*)*)';
        if Assigned(p.NextSibling) and rx.Exec(String(p.NextSibling.TextContent)) then
          m.IsPointer := PointerCount(rx.Match[0]);
        Member.Add(m);
      finally
        FreeAndNil(rx);
      end;
      except
        FreeAndNil(m);
      end;
    end;
    x := x.NextSibling;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkStruct.GenerateCode(const aCode: TStringTree);
var
  m: TMember;
  st: TStringTree;
  postfix, prefix: String;
  i, indent: Integer;
begin
  inherited GenerateCode(aCode);

  if Assigned(fList) then begin
    for m in fMember do begin
      if (m.ArrSize <> '') then
        fList.GenerateCode(m.ArrSize, aCode);
      fList.GenerateCode(m.Typ, aCode);
    end;
  end;

  st := aCode.GetOrCreateItem(KEYWORD_INTF).GetOrCreateItem(KEYWORD_STRUCT);
  if (st.LinesBefore.Count = 0) then
    st.LinesBefore.Add('type { structures }');
  st := st.GetOrCreateItem(GetPascalName(0, ''));
  if (st.LinesBefore.Count = 0) then begin
    postfix := ';';
    indent  := 50;
    st.LinesBefore.Add('  T%s = record', [ fName ]);
    if IsUnion then begin
      st.LinesBefore.Add('    case Integer of');
      postfix := ');';
      indent  := 42;
    end;
    for i := 0 to fMember.Count-1 do begin
      m := fMember[i];
      if IsUnion
        then prefix := Format('      %.3d: (', [ i ])
        else prefix := '    ';
      st.LinesBefore.Add(Format('%s%-*s%s%s', [ prefix, indent, PrepareName(m.Name, m.Typ) + ': ', List.GetPascalName(m.Typ, m.IsPointer, m.ArrSize), postfix ]));
    end;
    st.LinesAfter.Add('  end;');
    st.LinesAfter.Add('  P%s = ^T%0:s;', [ fName ]);
    st.LinesAfter.Add('  PP%s = ^P%0:s;', [ fName ]);
    st.LinesAfter.Add('');
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor THeaderGenerator.TvkStruct.Create;
begin
  inherited Create(otStruct);
  fMember := TMemberList.Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor THeaderGenerator.TvkStruct.Destroy;
begin
  FreeAndNil(fMember);
  inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkEnum//////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkEnum.GenPascalName(var aName: WideString; const aPointer: Integer; const aArrSize: WideString);
var i: Integer;
begin
  if (fName = '') then
    raise Exception.Create('enum with empty name');
  if (aPointer > 0) then begin
    aName := fName;
    for i := 0 to aPointer-1 do
      aName := 'P' + aName;
  end else
    aName := 'T' + fName;
  inherited GenPascalName(aName, aPointer, aArrSize);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkEnum.ReadXml(const xml: TDOMNode);
var
  x, p: TDOMNode;
  v: TValue;
begin
  Name    := GetNodeAttrib(xml, 'name');
  Expands := GetNodeAttrib(xml, 'expand', '');
  x := xml.FirstChild;
  while Assigned(x) do begin
    if (x.NodeName = 'enum') then begin
      v := TValue.Create;
      try
        v.Name := GetNodeAttrib(x, 'name');
        p := x.Attributes.GetNamedItem('value');
        if Assigned(p) then begin
          v.IsBit := false;
          v.Value := StrToValue(String(p.TextContent));
        end else begin
          p := x.Attributes.GetNamedItem('bitpos');
          if not Assigned(p) then
            raise XmlException.Create('enum without value or bitpos', xml);
          v.IsBit := true;
          v.Value := StrToValue(String(p.TextContent));
        end;

        if (v.Value = Unassigned) then
          raise XmlException.Create(WideString('invalid enum value (' + p.TextContent + ')'), xml);

        Values.Add(v);
      except
        FreeAndNil(v);
        raise;
      end;
    end;
    x := x.NextSibling;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkEnum.GenerateCode(const aCode: TStringTree);
var
  st, vt: TStringTree;
  i: Integer;
  v: TValue;
  postfix: String;
begin
  inherited GenerateCode(aCode);
  st := aCode
    .GetOrCreateItem(KEYWORD_INTF)
    .GetOrCreateItem(KEYWORD_ENUM);
  if (st.LinesBefore.Count = 0) then
    st.LinesBefore.Add('type { enumerations }');
  st := st.GetOrCreateItem(fName);
  if (st.LinesBefore.Count = 0) then begin
    st.LinesBefore.Add(Format('  %s = (', [GetPascalName(0, '')]));
    postfix := ',';
    vt := st.GetOrCreateItem(KEYWORD_ENUM_VALUES);
    for i := 0 to fValues.Count-1 do begin
      v := fValues[i];
      if (i = fValues.Count-1) and (fExpands = '') then
        postfix := '';
      if (v.IsBit)
        then vt.LinesBefore.Add(Format('    %-60s = (1 shl %s)%s', [v.Name, v.Value, postfix]))
        else vt.LinesBefore.Add(Format('    %-60s = %s%s',         [v.Name, v.Value, postfix]));
    end;
    if (fExpands <> '') then
      st.LinesAfter.Add(Format('    %-60s = %s', [fExpands + '_MAX_ENUM', '$7FFFFFFF']));
    st.LinesAfter.Add('  );');
    st.LinesAfter.Add('  P%s = ^T%0:s;', [ fName ]);
    st.LinesAfter.Add('  PP%s = ^P%0:s;', [ fName ]);
    st.LinesAfter.Add('');
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor THeaderGenerator.TvkEnum.Create;
begin
  inherited Create(otEnum);
  fValues := TValueList.Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor THeaderGenerator.TvkEnum.Destroy;
begin
  FreeAndNil(fValues);
  inherited Destroy;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkConst/////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkConst.GenerateCode(const aCode: TStringTree);
var
  st: TStringTree;
begin
  inherited GenerateCode(aCode);
  st := aCode
    .GetOrCreateItem(KEYWORD_INTF)
    .GetOrCreateItem(KEYWORD_CONST);
  if (st.LinesBefore.Count = 0) then
    st.LinesBefore.Add('const');
  st := st.GetOrCreateItem(fName);
  if (st.LinesBefore.Count = 0) then
    st.LinesBefore.Add(Format('  %-62s = %s;', [fName, fValue]));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor THeaderGenerator.TvkConst.Create;
begin
  inherited Create(otConst);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator//////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.GenerateCode(const aName: WideString; const aTemplate: String; const aOutput: String);
type
  TPosMap = specialize TutlMap<string, Integer>;
var
  CurrentName: WideString;
  CurrentNumber: Integer;
  Code: TStringTree;
  PosMap: TPosMap;

  procedure UpdateComment(const aRoot: TStringTree; const aName: String);
  var
    i: Integer;
    s, tmp: String;
    st: TStringTree;
  begin
    st := aRoot.GetOrCreateItem(aName);
    if PosMap.TryGetValue(aName, i) and (st.ItemCount > i) and (CurrentName <> '') then
      with st.CreateItemAt(aName + CurrentName, i).LinesBefore do begin
        s := ' ' + CurrentName + ' ';
        if ((Length(s) and 1) = 1) then
          s := s + '=';
        tmp := StringOfChar('=', (100 - Length(s)) div 2);
        s := '{ ' + tmp + s + tmp + ' }';
        Add('');
        Add(s);
      end;
    PosMap[aName] := st.ItemCount;
  end;

  procedure UpdateComments;
  var st: TStringTree;
  begin
    st := Code.GetOrCreateItem(KEYWORD_INTF);
    UpdateComment(st, KEYWORD_CONST);
    UpdateComment(st, KEYWORD_TYPES);
    UpdateComment(st, KEYWORD_ENUM);
    UpdateComment(st, KEYWORD_FUNCPTR);
    UpdateComment(st, KEYWORD_STRUCT);
    UpdateComment(st, KEYWORD_COMMAND);
    UpdateComment(st, KEYWORD_VAR);

    st := Code.GetOrCreateItem(KEYWORD_IMPL);
    UpdateComment(st, KEYWORD_CODE);
  end;

  procedure AddGuard(const aTree: TStringTree; const aName: String);
  var
    i: Integer;
  begin
    for i := 0 to aTree.ItemCount-1 do
      AddGuard(aTree.ItemsByIndex[i], aName);
    with aTree.GetOrCreateItem('GUARD' + aName).LinesBefore do begin
      Add('{$IFDEF ' + aName + '}');
    end;
  end;

  procedure RemoveGuard(const aTree: TStringTree; const aName: String);
  var
    i: Integer;
    g: TStringTree;
  begin
    for i := 0 to aTree.ItemCount-1 do
      RemoveGuard(aTree.ItemsByIndex[i], aName);
    g := aTree.GetOrCreateItem('GUARD' + aName);
    if (g = aTree.ItemsByIndex[aTree.ItemCount-1])
      then aTree.DestroyItem('GUARD' + aName)
      else with aTree.GetOrCreateItem('GUARD_END'+ aName).LinesAfter do begin
        Add('{$ENDIF}');
        Add('');
      end;
  end;

  procedure CreateGuard(const aName: String);
  begin
    if (aName = '') then
      exit;
    AddGuard(Code, aName);
  end;

  procedure CloseGuard(const aName: String);
  begin
    if (aName = '') then
      exit;
    RemoveGuard(Code, aName);
  end;

  procedure GenerateFeatureCode(const aName: String);
  var
    i: Integer;
  begin
    i := fObjects.IndexOfObj(aName, VK_OBJECT_ALL);
    if (i >= 0) then
      fObjects[i].GenerateCode(Code);
  end;

  function GenerateEnum(const xml: TDOMNode): Boolean;
  var
    name: DOMString;
    ex: DOMString;
    value: DOMString;
    offset: Integer;
    s: String;
    c: TvkConst;
  begin
    result := false;
    name := GetNodeAttrib(xml, 'name');
    if TryGetNodeAttrib(xml, 'extends', ex) then begin
      if (CurrentNumber <= 0) then
        raise Exception.Create('current extension has no number');
      offset := StrToInt(GetNodeAttrib(xml, 'offset'));
      offset := 1000000000 + 1000 * (CurrentNumber-1) + offset;
      if (GetNodeAttrib(xml, 'dir', '') = '-') then
        offset := -1 * offset;
      Code
        .GetOrCreateItem(KEYWORD_INTF)
        .GetOrCreateItem(KEYWORD_ENUM)
        .GetOrCreateItem(ex)
        .GetOrCreateItem(KEYWORD_ENUM_VALUES)
        .LinesBefore.Add(Format('    %-60s = %s,', [name, IntToStr(offset)]));
    end else begin
      if not TryGetNodeAttrib(xml, 'value', value) then
        exit;
      s := StringReplace(string(value), '"', '''', [rfReplaceAll]);
      c := TvkConst.Create;
      try
        c.Name  := name;
        c.Value := s;
        fObjects.AddObject(c);
      except
        FreeAndNil(c);
        raise;
      end;
      c.GenerateCode(Code);
    end;
    result := true;
  end;

  procedure GenerateFeatureCode(const xml: TDOMNode);
  var
    x: TDOMNode;
  begin
    x := xml.FirstChild;
    while Assigned(x) do begin
      if (x.NodeName = 'type') or
         (x.NodeName = 'command') then
      begin
        GenerateFeatureCode(GetNodeAttrib(x, 'name'));
      end else if (x.NodeName = 'enum') then begin
        if not GenerateEnum(x) then
          GenerateFeatureCode(GetNodeAttrib(x, 'name'));
      end;
      x := x.NextSibling;
    end;
  end;

  procedure Generate(const xml: TDOMNode);
  var
    x: TDOMNode;
    g: DOMString;
  begin
    UpdateComments;
    g := GetNodeAttrib(xml, 'protect', '');
    CreateGuard(g);
    try
      CurrentName := GetNodeAttrib(xml, 'name');
      if not TryStrToInt(String(GetNodeAttrib(xml, 'number', '-1')), CurrentNumber) then
        CurrentNumber := -1;
      WriteLn('generate code for feature: ', CurrentName);
      x := xml.FirstChild;
      while Assigned(x) do begin
        if (x.NodeName = 'require') then
          GenerateFeatureCode(x);
        x := x.NextSibling;
      end;
    finally
      CloseGuard(g);
      UpdateComments;
      CurrentName := '';
    end;
  end;

  procedure EnableFeature;
  var x: TDOMNode;
  begin
    GenerateFeatureCode('VK_API_VERSION');
    GenerateFeatureCode('VK_API_VERSION_MAJOR');
    GenerateFeatureCode('VK_API_VERSION_MINOR');
    GenerateFeatureCode('VK_API_VERSION_BUGFIX');

    x := fDocument.DocumentElement.FirstChild;
    while Assigned(x) do begin
      if (x.NodeName = 'feature') and (GetNodeAttrib(x, 'api', '') = aName) then
        Generate(x);
      x := x.NextSibling;
    end;
  end;

  procedure EnableExtensions;
  var
    x: TDOMNode;
    g: String;
  begin
    x := fDocument.DocumentElement.FindNode('extensions');
    if not Assigned(x) then
      exit;
    x := x.FirstChild;
    while Assigned(x) do begin
      if (x.NodeName = 'extension') and (GetNodeAttrib(x, 'supported', '') = aName) then
        Generate(x);
      x := x.NextSibling;
    end;
  end;

  procedure RemoveEmptyLines(const aText: TStrings);
  var
    i: Integer;
    b: Boolean;
    rx: TRegExpr;
  begin
    i := 0;
    rx := TRegExpr.Create('{%.*?%}');
    try
      while (i < aText.Count) do begin
        if (rx.Exec(aText[i])) then begin
          aText.Delete(i);
          continue;
        end;

        if (Trim(aText[i]) = '') then begin
          if b then begin
            aText.Delete(i);
            continue;
          end else
            b := true;
        end else
          b := false;

        inc(i);
      end;
    finally
      FreeAndNil(rx);
    end;
  end;

  procedure PrepareTemplate;
  var
    sl: TStringList;
    s, n: String;
    st: TStringTree;
    p0, p1: Integer;
  begin
    sl := TStringList.Create;
    try
      sl.LoadFromFile(aTemplate);
      s := sl.Text;
      p0 := Pos('{%', s);
      while (p0 > 0) do begin
        p1 := Pos('%}', s, p0);
        if (p1 <= 0) then
          raise Exception.Create('unclosed tag in template');
        n  := Trim(Copy(s, p0+2, p1-p0-2));
        st := Code.Items[n];
        n  := Copy(s, p0, p1 - p0 + 2);
        if Assigned(st)
          then s := StringReplace(s, n, st.Text, [rfReplaceAll])
          else s := StringReplace(s, n, '', [rfReplaceAll]);
        p0 := Pos('{%', s, p0);
      end;
      sl.Text := Trim(s);
      RemoveEmptyLines(sl);
      sl.SaveToFile(aOutput);
    finally
      FreeAndNil(sl);
    end;
  end;

begin
  if not Assigned(fDocument) then
    raise Exception.Create('no xml file loaded, did you call ReadFile before?');

  Code := TStringTree.Create;
  PosMap := TPosMap.Create;
  try
    Code.GetOrCreateItem(KEYWORD_COMMENT).LinesBefore.Text := Trim(String(fComment));
    with Code.GetOrCreateItem(KEYWORD_INTF) do begin
      GetOrCreateItem(KEYWORD_CONST).LinesAfter.Add('');
      GetOrCreateItem(KEYWORD_TYPES).LinesAfter.Add('');
      GetOrCreateItem(KEYWORD_ENUM).LinesAfter.Add('');
      GetOrCreateItem(KEYWORD_FUNCPTR).LinesAfter.Add('');
      GetOrCreateItem(KEYWORD_STRUCT).LinesAfter.Add('');
      GetOrCreateItem(KEYWORD_COMMAND).LinesAfter.Add('');
      GetOrCreateItem(KEYWORD_VAR).LinesAfter.Add('');
    end;
    with Code.GetOrCreateItem(KEYWORD_IMPL) do begin
      GetOrCreateItem(KEYWORD_CODE).LinesAfter.Add('');
    end;
    Code.GetOrCreateItem(KEYWORD_IMPL);
    EnableFeature;
    EnableExtensions;
    PrepareTemplate;
  finally
    FreeAndNil(PosMap);
    FreeAndNil(Code);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.ReadFile(const aFilename: String);
var
  fs: TFileStream;
begin
  if not FileExists(aFilename) then
    raise Exception.Create('file does not exist: ' + aFilename);
  fs := TFileStream.Create(aFilename, fmOpenRead);
  try
    ReadFile(fs);
  finally
    FreeAndNil(fs);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.ReadFile(const aStream: TStream);
var
  xml: TDOMNode;

  procedure ParseTypes(const xml: TDOMNode);
  var
    x: TDOMNode;
  begin
    x := xml.FirstChild;
    while Assigned(x) do begin
      TvkObject.CreateFromXml(x, fObjects);
      x := x.NextSibling;
    end;
  end;

begin
  Clear;
  ReadXMLFile(fDocument, aStream);

  WriteLn('read xml data');
  xml := fDocument.DocumentElement.FirstChild;
  while Assigned(xml) do begin
    if (xml.NodeName = 'types') or (xml.NodeName = 'commands') then
      ParseTypes(xml)
    else if (xml.NodeName = 'enums') then
      TvkObject.CreateFromXml(xml, fObjects)
    else if (xml.NodeName = 'comment') then
      fComment := WideString(Trim(String(xml.TextContent)));
    xml := xml.NextSibling;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.Clear;

  procedure CreateBaseType(const aName, aAlias, aParent: DOMString);
  var t: TvkTypeBase;
  begin
    t := TvkTypeBase.Create(otType);
    try
      t.Name   := aName;
      t.Alias  := aAlias;
      t.Parent := aParent;
      t.List   := fObjects;
      fObjects.Add(t);
    except
      FreeAndNil(t);
      raise;
    end;
  end;

begin
  fObjects.Clear;

  CreateBaseType('void',      'VkVoid',   '');
  CreateBaseType('uint8_t',   'VkUint8',  '');
  CreateBaseType('uint16_t',  'VkUint16', '');
  CreateBaseType('uint32_t',  'VkUint32', '');
  CreateBaseType('uint64_t',  'VkUint64', '');
  CreateBaseType('int16_t',   'VkInt16',  '');
  CreateBaseType('int32_t',   'VkInt32',  '');
  CreateBaseType('int64_t',   'VkInt64',  '');
  CreateBaseType('float',     'VkFloat',  '');
  CreateBaseType('double',    'VkDouble', '');
  CreateBaseType('char',      'VkChar',   '');
  CreateBaseType('size_t',    'VkSize',   '');
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor THeaderGenerator.Create;
begin
  inherited Create;
  fObjects := TvkObjectList.Create;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
destructor THeaderGenerator.Destroy;
begin
  FreeAndNil(fObjects);
  FreeAndNil(fDocument);
  inherited Destroy;
end;

end.