Vulkan/projects/generator/HeaderGenerator.pas

unit HeaderGenerator;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, DOM, fgl, variants;

type
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
  THeaderGenerator = class(TObject)
  private type
    TvkObjectType = (
      otUnknown,
      otType,
      otHandle,
      otFuncPtr,
      otStruct,
      otEnum,
      otCommand);
    TvkObjectTypes = set of TvkObjectType;

    TvkObject = class;
    TvkObjectList = class(specialize TFPGObjectList<TvkObject>)
    public
      function FindObj(const aName: DOMstring; const aTypes: TvkObjectTypes; out aObject): Boolean;
      procedure MarkObj(const aName: DOMstring; const aTypes: TvkObjectTypes; const aMark: Integer);
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkObject = class(TObject)
    private
      fType: TvkObjectType;
      fMark: Integer;
      fName: DOMString;
      fComment: DOMString;
      fList: TvkObjectList;
    private
      procedure SetMark(aValue: Integer);
    protected
      procedure DoMark(const aMark: Integer); virtual;
    public
      property Mark: Integer read fMark write SetMark;
      property Name: DOMString read fName write fName;
      property Comment: DOMString read fComment write fComment;
      property VkType: TvkObjectType read fType;
      property List: TvkObjectList read fList write fList;

      procedure AddCommentFromXml(xml: TDOMNode);

      constructor Create(const aType: TvkObjectType);
    public
      class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkObject;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkTypeSimple = class(TvkObject)
    private
      fParent: DOMString;
    protected
      procedure DoMark(const aMark: Integer); override;
    public
      property Parent: DOMString read fParent write fParent;
    public
      class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeSimple;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkTypeHandle = class(TvkTypeSimple)
    private
      fNonDispatchable: Boolean;
    public
      property NonDispatchable: Boolean read fNonDispatchable write fNonDispatchable;
    public
      class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeHandle;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkTypeFunction = class(TvkObject)
    private type
      TArgument = class(TObject)
        Typ: DOMString;
        Name: DOMString;
        IsPointer: Boolean;
        IsConst: Boolean;
      end;
      TArgumentList = specialize TFPGObjectList<TArgument>;
    private
      fReturnValue: TArgument;
      fArguments: TArgumentList;
    protected
      procedure DoMark(const aMark: Integer); override;
    public
      property ReturnValue: TArgument     read fReturnValue;
      property Arguments:   TArgumentList read fArguments;

      constructor Create(const aType: TvkObjectType);
      destructor Destroy; override;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkTypeFunctionPtr = class(TvkTypeFunction)
    public
      class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeFunctionPtr;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkCommand = class(TvkTypeFunction)
    public
      class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkCommand;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkTypeStruct = class(TvkObject)
    private type
      TMember = class(TObject)
        Typ: DOMString;
        Name: DOMString;
        ArrSize: Integer;
        IsPointer: Boolean;
        IsConst: Boolean;
      end;
      TMemberList = specialize TFPGObjectList<TMember>;
    private
      fIsUnion: Boolean;
      fMember: TMemberList;
    protected
      procedure DoMark(const aMark: Integer); override;
    public
      property Member: TMemberList read fMember;
      property IsUnion: Boolean read fIsUnion write fIsUnion;

      constructor Create(const aType: TvkObjectType);
      destructor Destroy; override;
    public
      class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeStruct;
    end;

    ////////////////////////////////////////////////////////////////////////////////////////////
    TvkTypeEnum = class(TvkObject)
    private type
      TValue = class(TObject)
        Name: DOMString;
        Value: Variant;
        IsBit: Boolean;
      end;
      TValueList = specialize TFPGObjectList<TValue>;
    private
      fValues: TValueList;
    public
      property Values: TValueList read fValues;

      constructor Create(const aType: TvkObjectType);
      destructor Destroy; override;
     public
      class function CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeEnum;
    end;

  private const
    VK_OBJECT_TYPES: TvkObjectTypes = [ otType, otHandle, otFuncPtr, otStruct, otEnum ];

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

  public
    procedure ReadFile(const aFilename: String);
    procedure ReadFile(const aStream: TStream);

    procedure Clear;

    constructor Create;
    destructor Destroy; override;
  end;

implementation

uses
  XMLRead, RegExpr;

type
  XmlException = class(Exception)
  public
    xml: TDOMNode;
    constructor Create(const aMsg: WideString; const aXml: TDOMNode);
  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';
    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 + ' witout child ''' + aName + '''', xml);
  result := 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 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.TvkObjectList////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
function THeaderGenerator.TvkObjectList.FindObj(const aName: DOMstring; const aTypes: TvkObjectTypes; out aObject): Boolean;
var
  o: TvkObject;
begin
  if (aName = '') then
    raise Exception.Create('empty name');

  result             := true;
  TvkObject(aObject) := nil;
  for o in self do begin
    if (o.VkType in aTypes) and (o.Name = aName) then begin
      TvkObject(aObject) := o;
      exit;
    end;
  end;
  result := false;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkObjectList.MarkObj(const aName: DOMstring; const aTypes: TvkObjectTypes;
  const aMark: Integer);
var o: TvkObject;
begin
  if FindObj(aName, aTypes, o)
    then o.Mark := aMark
    else WriteResolveWarning(aName);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkObject////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkObject.SetMark(aValue: Integer);
begin
  if (fMark <> 0) then
    exit;
  fMark := aValue;
  DoMark(fMark);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkObject.DoMark(const aMark: Integer);
begin
  WriteLn(Format('  %-10s%-50s marked for generation', [FormatType(fType), fName]));
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkObject.AddCommentFromXml(xml: TDOMNode);
begin
  xml := xml.FindNode('comment');
  if Assigned(xml) then
    fComment := xml.TextContent;
end;

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

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function THeaderGenerator.TvkObject.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkObject;
var
  s: DOMString;
  x: TDOMNode;
begin
  result := nil;
  if (xml.NodeName = 'type') and xml.HasAttributes then begin
    x := xml.Attributes.GetNamedItem('category');
    if not Assigned(x) then
      exit;
    s := x.TextContent;
    if (s = 'basetype') or (s = 'bitmask') then
      result := TvkTypeSimple.CreateFromXml(xml)
    else if (s = 'handle') then
      result := TvkTypeHandle.CreateFromXml(xml)
    else if (s = 'funcpointer') then
      result := TvkTypeFunctionPtr.CreateFromXml(xml)
    else if (s = 'struct') or (s = 'union') then
      result := TvkTypeStruct.CreateFromXml(xml);
  end else if (xml.NodeName = 'command') then
    result := TvkCommand.CreateFromXml(xml);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkTypeSimple////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkTypeSimple.DoMark(const aMark: Integer);
begin
  inherited DoMark(aMark);
  if (fParent <> '') and Assigned(fList) then
      fList.MarkObj(fParent, VK_OBJECT_TYPES, aMark);
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function THeaderGenerator.TvkTypeSimple.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeSimple;
begin
  result := TvkTypeSimple.Create(otType);
  try
    result.Name   := GetNodeValue(xml, 'name');
    result.Parent := GetNodeValue(xml, 'type');
  except
    FreeAndNil(result);
    raise;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkTypeHandle////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function THeaderGenerator.TvkTypeHandle.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeHandle;
begin
  result := TvkTypeHandle.Create(otHandle);
  try
    result.Name            :=  GetNodeValue(xml, 'name');
    result.Parent          :=  GetNodeValue(xml, 'parent', 'VkHandle');
    result.NonDispatchable := (GetNodeValue(xml, 'type', '') = 'VK_DEFINE_NON_DISPATCHABLE_HANDLE');
  except
    FreeAndNil(result);
    raise;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkTypeFunction.DoMark(const aMark: Integer);
var a: TArgument;
begin
  inherited DoMark(aMark);
  if Assigned(fList) then begin
    fList.MarkObj(fReturnValue.Typ, VK_OBJECT_TYPES, aMark);
    for a in fArguments do
      fList.MarkObj(a.Typ, VK_OBJECT_TYPES, aMark);
  end;
end;

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

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

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkTypeFunctionPtr///////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function THeaderGenerator.TvkTypeFunctionPtr.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeFunctionPtr;
var
  x, p: TDOMNode;
  a: TArgument;
  rx: TRegExpr;
begin
  result := TvkTypeFunctionPtr.Create(otFuncPtr);
  try
    x := xml.FindNode('name');
    if not Assigned(x) then
      raise XmlException.Create(xml.NodeName + ' witout child ''name''', xml);
    result.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*\(');
    try
      if not rx.Exec(String(p.TextContent)) then
        raise XmlException.Create('unable to parse return type of function pointer', xml);

      result.ReturnValue.IsConst   := (Trim(rx.Match[1]) = 'const');
      result.ReturnValue.Typ       := WideString(Trim(rx.Match[3]));
      result.ReturnValue.IsPointer := (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*([-_A-Za-z0-9]+)';
            if not rx.Exec(String(p.TextContent)) then
              raise XmlException.Create('unable to parse function pointer arguments', xml);

            a.IsPointer := (rx.Match[1] = '*');
            a.Name      := WideString(Trim(rx.Match[2]));
            result.Arguments.Add(a);
          except
            FreeAndNil(a)
          end;
        end;
        x := x.NextSibling;
      end;
    finally
      FreeAndNil(rx);
    end;
  except
    FreeAndNil(result);
    raise;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkCommand///////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function THeaderGenerator.TvkCommand.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkCommand;

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

  procedure ParseParam(const x: TDOMNode);
  var
    p: TDOMNode;
    a: TArgument;
  begin
    a := TArgument.Create;
    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');
      a.IsPointer := Assigned(p.NextSibling)     and (Trim(p.NextSibling.TextContent)     = '*');
      result.Arguments.Add(a);
    except
      FreeAndNil(a);
      raise;
    end;
  end;

var
  x: TDOMNode;
begin
  result := TvkCommand.Create(otCommand);
  try
    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;
  except
    FreeAndNil(result);
    raise;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
procedure THeaderGenerator.TvkTypeStruct.DoMark(const aMark: Integer);
var m: TMember;
begin
  inherited DoMark(aMark);
  if Assigned(fList) then begin
    for m in fMember do
      fList.MarkObj(m.Typ, VK_OBJECT_TYPES, aMark);
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkTypeStruct////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor THeaderGenerator.TvkTypeStruct.Create(const aType: TvkObjectType);
begin
  inherited Create(aType);
  fMember := TMemberList.Create;
end;

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

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function THeaderGenerator.TvkTypeStruct.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeStruct;
var
  x, p: TDOMNode;
  m: TMember;
  rx: TRegExpr;
begin
  result := TvkTypeStruct.Create(otStruct);
  try
    result.Name    := GetNodeAttrib(xml, 'name');
    result.IsUnion := (GetNodeAttrib(xml, 'category') = 'union');

    x := xml.FirstChild;
    while Assigned(x) do begin
      if (x.NodeName = 'member') then begin
        m := TMember.Create;
        try
          // read name
          p := x.FindNode('name');
          if not Assigned(p) then
            raise XmlException.Create('struct member without name', xml);
          m.Name := p.TextContent;
          if Assigned(p.NextSibling) then
            m.Name := m.Name + p.NextSibling.TextContent;
          m.Name := Trim(m.Name);
          rx := TRegExpr.Create('([-_A-Za-z0-9]+)\s*\[\s*([0-9]+)\s*\]');
          try
            if rx.Exec(String(m.Name)) then begin
              m.Name := WideString(rx.Match[1]);
              m.ArrSize := StrToInt(rx.Match[2]);
            end;
          finally
            FreeAndNil(rx);
          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');
          m.IsPointer := Assigned(p.NextSibling)     and (Trim(p.NextSibling.TextContent)     = '*');
          result.Member.Add(m);
        except
          FreeAndNil(m);
        end;
      end;
      x := x.NextSibling;
    end;
  except
    FreeAndNil(result);
    raise;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator.TvkTypeEnum//////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
constructor THeaderGenerator.TvkTypeEnum.Create(const aType: TvkObjectType);
begin
  inherited Create(aType);
  fValues := TValueList.Create;
end;

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

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
class function THeaderGenerator.TvkTypeEnum.CreateFromXml(const xml: TDOMNode): THeaderGenerator.TvkTypeEnum;
var
  x, p: TDOMNode;
  v: TValue;

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

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

      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 := High(Cardinal)
          else result := High(UInt64);
      end;

      if (result = Unassigned) then
        raise XmlException.Create(WideString('invalid enum value (' + s + ')'), xml);
    finally
      FreeAndNil(rx);
    end;
  end;

begin
  result := TvkTypeEnum.Create(otEnum);
  try
    result.Name := GetNodeAttrib(xml, 'name');
    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 := false;
            v.Value := StrToValue(String(p.TextContent));
          end;
          result.Values.Add(v);
        except
          FreeAndNil(v);
          raise;
        end;
      end;
      x := x.NextSibling;
    end;
  except
    FreeAndNil(result);
    raise;
  end;
end;

////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
//THeaderGenerator//////////////////////////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
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;
  CurrentMark: Integer;

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

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

  procedure EnableFeature(const xml: TDOMNode);
  var
    x: TDOMNode;
  begin
    x := xml.FirstChild;
    while Assigned(x) do begin
      if (x.NodeName = 'require') then
        EnableFeature(x)
      else if (x.NodeName = 'type') then
        fObjects.MarkObj(GetNodeAttrib(x, 'name'), VK_OBJECT_TYPES, CurrentMark)
      else if (x.NodeName = 'command') then
        fObjects.MarkObj(GetNodeAttrib(x, 'name'), [ otCommand ], CurrentMark);

      x := x.NextSibling;
    end;
  end;

begin
  Clear;
  ReadXMLFile(fDocument, aStream);

  CurrentMark := 1;
  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
      AddObject(TvkTypeEnum.CreateFromXml(xml))
    else if (xml.NodeName = 'comment') then
      fComment := xml.TextContent
    else if (xml.NodeName = 'feature') then
      EnableFeature(xml);
    xml := xml.NextSibling;
  end;

  WriteLn('generate header');

end;

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

  procedure CreateBaseType(const aName: DOMString);
  var o: TvkObject;
  begin
    o := TvkTypeSimple.Create(otType);
    try
      o.Name := aName;
      o.List := fObjects;
      fObjects.Add(o);
    except
      FreeAndNil(o);
      raise;
    end;
  end;

begin
  fComment := '';
  fObjects.Clear;
  CreateBaseType('void');
  CreateBaseType('uint16_t');
  CreateBaseType('uint32_t');
  CreateBaseType('uint64_t');
  CreateBaseType('int16_t');
  CreateBaseType('int32_t');
  CreateBaseType('int64_t');
  CreateBaseType('float');
  CreateBaseType('double');
  CreateBaseType('char');
  CreateBaseType('uint8_t');
  CreateBaseType('size_t');
  CreateBaseType('VkHandle');
end;

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

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

end.