source: branches/generator/UGrammer.pas

unit UGrammer;

{$mode delphi}{$H+}

interface

uses
  Classes, SysUtils, fgl, DOM, XmlWrite, UXMLUtils, Math;

type
  TRule = class;
  TRules = class;
  TGrammer = class;
  TRuleItems = class;
  TLookupTable = class;

  TRuleItemType = (ritTerminal, ritNonTerminal, ritSubItems, ritTerminalRange);
  TGrammerNotation = (gnBnf, gnEbnf);
  TLookupTableAction = (taCreate, taReference);

  { TRuleItem }

  TRuleItem = class
  private
    FGrammer: TGrammer;
    FParentRule: TRule;
    procedure SetGrammer(AValue: TGrammer);
    procedure SetParentRule(AValue: TRule);
  public
    Optional: Boolean;
    Repetitive: Boolean;
    AnyExcept: Boolean;
    RuleItemType: TRuleItemType;
    Terminal: string;
    TerminalFrom: string;
    TerminalTo: string;
    EscapedStrings: Boolean;
    NonTerminalName: string;
    NonTerminal: TRule;
    SubItems: TRuleItems;
    LookupTableUsed: Boolean;
    LookupTable: TLookupTable;
    LookupTableName: string;
    LookupTableAction: TLookupTableAction;
    function GetCharLength: Integer;
    procedure LoadFromXmlNode(Node: TDOMNode);
    procedure SaveToXmlNode(Node: TDOMNode);
    function GetString: string;
    function ExportAsString(Notation: TGrammerNotation): string;
    constructor Create;
    destructor Destroy; override;
    property Grammer: TGrammer read FGrammer write SetGrammer;
    property ParentRule: TRule read FParentRule write SetParentRule;
  end;

  TRuleType = (rtAnd, rtOr);

  { TRuleItems }

  TRuleItems = class(TFPGObjectList<TRuleItem>)
  private
    FParentRule: TRule;
    procedure SetParentRule(AValue: TRule);
  public
    Grammer: TGrammer;
    RuleType: TRuleType;
    WithWhiteSpeaces: Boolean;
    function GetCharLength: Integer;
    procedure LoadFromXmlNode(Node: TDOMNode);
    procedure SaveToXmlNode(Node: TDOMNode);
    procedure UpdateRuleReference;
    function GetString: string;
    function ExportAsString(Notation: TGrammerNotation): string;
    property ParentRule: TRule read FParentRule write SetParentRule;
  end;

  TRuleLinkType = (ltRequire);

  TRuleLink = class
    LinkType: TRuleLinkType;
    Rule: TRule;
  end;

  TRuleLinks = class(TFPGObjectList<TRuleLink>)

  end;

  TRuleLevel = (rlParser, rlTokenizer);

  { TRule }

  TRule = class
  private
    FGrammer: TGrammer;
    procedure SetGrammer(AValue: TGrammer);
  public
    Name: string;
    CreateSourceNode: Boolean;
    Level: TRuleLevel;
    Items: TRuleItems;
    Links: TRuleLinks;
    constructor Create;
    destructor Destroy; override;
    procedure GetUsedByRule(RefRule: TRule; UsedByRules: TStrings);
    procedure LoadFromXmlNode(Node: TDOMNode);
    procedure SaveToXmlNode(Node: TDOMNode);
    function GetString: string;
    function ExportAsString(Notation: TGrammerNotation): string;
    property Grammer: TGrammer read FGrammer write SetGrammer;
  end;

  { TRules }

  TRules = class(TFPGObjectList<TRule>)
    Grammer: TGrammer;
    function FindName(Name: string): TRule;
    procedure LoadFromXmlNode(Node: TDOMNode);
    procedure SaveToXmlNode(Node: TDOMNode);
    function GetString: string;
    function ExportAsString(Notation: TGrammerNotation): string;
  end;

  TLookupTableItem = class
    Name: string;
  end;

  { TLookupTable }

  TLookupTable = class
    Name: string;
    Grammer: TGrammer;
    Items: TFPGObjectList<TLookupTableItem>;
    procedure LoadFromXmlNode(Node: TDOMNode);
    procedure SaveToXmlNode(Node: TDOMNode);
    constructor Create;
    destructor Destroy; override;
  end;

  { TLookupTables }

  TLookupTables = class(TFPGObjectList<TLookupTable>)
    Grammer: TGrammer;
    function FindName(Name: string): TLookupTable;
    procedure LoadFromXmlNode(Node: TDOMNode);
    procedure SaveToXmlNode(Node: TDOMNode);
  end;

  { TGrammer }

  TGrammer = class
  private
    FModified: Boolean;
    FOnChange: TNotifyEvent;
    FOnDestroy: TNotifyEvent;
    procedure SetModified(AValue: Boolean);
    procedure DoChange;
    procedure DoDestroy;
  public
    FileName: string;
    Rules: TRules;
    LookupTables: TLookupTables;
    TopRule: TRule;
    WhiteSpaceRule: TRule;
    procedure LoadFromXmlFile(FileName: string);
    procedure SaveToXmlFile(FileName: string);
    procedure Clear;
    constructor Create;
    destructor Destroy; override;
    procedure GetUsedByRule(RefRule: TRule; UsedByRules: TStrings);
    function GetString: string;
    function ExportAsString(Notation: TGrammerNotation): string;
    procedure Change;
    property Modified: Boolean read FModified write SetModified;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
  end;

const
  RuleLevelText: array[TRuleLevel] of string = ('Parser', 'Tokenizer');
  RuleTypeText: array[TRuleType] of string = ('and', 'or');


implementation

{ TLookupTables }

function TLookupTables.FindName(Name: string): TLookupTable;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Name <> Name) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

procedure TLookupTables.LoadFromXmlNode(Node: TDOMNode);
var
  RuleNode: TDOMNode;
  LookupTable: TLookupTable;
begin
  RuleNode := Node.FirstChild;
  while Assigned(RuleNode) do begin
    if RuleNode.NodeName = 'LookupTable' then begin
      LookupTable := TLookupTable.Create;
      LookupTable.Grammer := Grammer;
      LookupTable.LoadFromXmlNode(RuleNode);
      Add(LookupTable);
    end;
    RuleNode := RuleNode.NextSibling;
  end;
end;

procedure TLookupTables.SaveToXmlNode(Node: TDOMNode);
var
  LookupTable: TLookupTable;
  RuleNode: TDOMNode;
begin
  for LookupTable in Self do begin
    RuleNode := Node.OwnerDocument.CreateElement('LookupTable');
    LookupTable.SaveToXmlNode(RuleNode);
    Node.AppendChild(RuleNode);
  end;
end;

{ TLookupTable }

procedure TLookupTable.LoadFromXmlNode(Node: TDOMNode);
begin
  Name := ReadString(Node, 'Name', '');
end;

procedure TLookupTable.SaveToXmlNode(Node: TDOMNode);
begin
  WriteString(Node, 'Name', Name);
end;

constructor TLookupTable.Create;
begin
  Items := TFPGObjectList<TLookupTableItem>.Create;
end;

destructor TLookupTable.Destroy;
begin
  FreeAndNil(Items);
  inherited Destroy;
end;

{ TGrammer }

procedure TGrammer.SetModified(AValue: Boolean);
begin
  if FModified = AValue then Exit;
  FModified := AValue;
  if AValue then DoChange;
end;

procedure TGrammer.DoChange;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TGrammer.DoDestroy;
begin
  if Assigned(FOnDestroy) then FOnDestroy(Self);
end;

procedure TGrammer.LoadFromXmlFile(FileName: string);
var
  Doc: TXMLDocument;
  RootNode: TDOMNode;
  RulesNode: TDOMNode;
  Rule: TRule;
begin
  Self.FileName := FileName;
  Rules.Clear;
  try
    ReadXMLFileParser(Doc, FileName);

    RootNode := Doc.DocumentElement;
    if RootNode.NodeName = 'GrammerProject' then begin
      RulesNode := RootNode.FindNode('Rules');
      if Assigned(RulesNode) then begin
        Rules.LoadFromXmlNode(RulesNode);
      end;
      RulesNode := RootNode.FindNode('LookupTables');
      if Assigned(RulesNode) then begin
        LookupTables.LoadFromXmlNode(RulesNode);
      end;

      TopRule := Rules.FindName(ReadString(RootNode, 'TopRule', ''));
      WhiteSpaceRule := Rules.FindName(ReadString(RootNode, 'WhiteSpaceRule', ''));
    end;
  finally
    FreeAndNil(Doc);
  end;

  // Update rule references
  for Rule in Rules do
    Rule.Items.UpdateRuleReference;
end;

procedure TGrammer.SaveToXmlFile(FileName: string);
var
  Doc: TXMLDocument;
  RootNode: TDOMNode;
  RulesNode: TDOMNode;
begin
  Self.FileName := FileName;
  Doc := TXMLDocument.Create;
  try
    RootNode := Doc.CreateElement('GrammerProject');
    Doc.AppendChild(RootNode);

    RulesNode := Doc.CreateElement('Rules');
    RootNode.AppendChild(RulesNode);
    Rules.SaveToXmlNode(RulesNode);

    RulesNode := Doc.CreateElement('LookupTables');
    RootNode.AppendChild(RulesNode);
    LookupTables.SaveToXmlNode(RulesNode);

    if Assigned(TopRule) then
      WriteString(RootNode, 'TopRule', TopRule.Name);
    if Assigned(WhiteSpaceRule) then
      WriteString(RootNode, 'WhiteSpaceRule', WhiteSpaceRule.Name);

    WriteXMLFile(Doc, FileName);
    Modified := False;
  finally
    FreeAndNil(Doc);
  end;
end;

procedure TGrammer.Clear;
begin
  TopRule := nil;
  Rules.Clear;
end;

constructor TGrammer.Create;
begin
  Rules := TRules.Create;
  Rules.Grammer := Self;
  LookupTables := TLookupTables.Create;
  LookupTables.Grammer := Self;
end;

destructor TGrammer.Destroy;
begin
  DoDestroy;
  FreeAndNil(LookupTables);
  FreeAndNil(Rules);
  inherited Destroy;
end;

procedure TGrammer.GetUsedByRule(RefRule: TRule; UsedByRules: TStrings);
var
  Rule: TRule;
begin
  UsedByRules.Clear;
  for Rule in Rules do
    Rule.GetUsedByRule(RefRule, UsedByRules);
end;

function TGrammer.GetString: string;
begin
  Result := Rules.GetString;
end;

function TGrammer.ExportAsString(Notation: TGrammerNotation): string;
begin
  Result := Rules.ExportAsString(Notation);
end;

procedure TGrammer.Change;
begin
  DoChange;
end;

{ TRuleItem }

procedure TRuleItem.SaveToXmlNode(Node: TDOMNode);
var
  SubItemsNode: TDOMNode;
begin
  WriteInteger(Node, 'Type', Integer(RuleItemType));
  WriteBoolean(Node, 'Optional', Optional);
  WriteBoolean(Node, 'Repetitive', Repetitive);
  WriteBoolean(Node, 'AnyExcept', AnyExcept);
  WriteBoolean(Node, 'EscapedStrings', EscapedStrings);

  case RuleItemType of
    ritTerminal: WriteString(Node, 'Terminal', Terminal);
    ritNonTerminal: WriteString(Node, 'NonTerminal', NonTerminal.Name);
    ritSubItems: begin
      SubItemsNode := Node.OwnerDocument.CreateElement('SubItems');
      Node.AppendChild(SubItemsNode);
      SubItems.SaveToXmlNode(SubItemsNode);
    end;
    ritTerminalRange: begin
      WriteString(Node, 'TerminalFrom', TerminalFrom);
      WriteString(Node, 'TerminalTo', TerminalTo);
    end;
  end;
  WriteBoolean(Node, 'LookupTableUsed', LookupTableUsed);
  WriteString(Node, 'LookupTable', LookupTableName);
  WriteInteger(Node, 'LookupTableAction', Integer(LookupTableAction));
end;

function TRuleItem.GetString: string;
begin
  case RuleItemType of
    ritTerminal: Result := '"' + Terminal + '"';
    ritNonTerminal: Result := NonTerminal.Name;
    ritSubItems: Result := '(' + SubItems.GetString + ')';
    ritTerminalRange: Result := '(' + TerminalFrom + ' .. ' + TerminalTo + ')';
  end;
  if Optional then Result := '+' + Result;
  if Repetitive then Result := '*' + Result;
  if AnyExcept then Result := '!' + Result;
end;

function TRuleItem.ExportAsString(Notation: TGrammerNotation): string;
begin
  case Notation of
    gnBnf: begin
      case RuleItemType of
        ritTerminal: Result := Terminal;
        ritNonTerminal: Result := '<' + NonTerminal.Name + '>';
        ritSubItems: begin
          if not Optional and not Repetitive then
            Result := '(' + SubItems.ExportAsString(Notation) + ')'
            else Result := SubItems.ExportAsString(Notation);
        end;
        ritTerminalRange: Result := '(' + TerminalFrom + ' .. ' + TerminalTo + ')';
      end;
      if Optional and not Repetitive then Result := '[' + Result + ']';
      if Repetitive then Result := '{' + Result + '}';
      if AnyExcept then Result := 'other then ' + Result;
    end;
    gnEbnf: begin
      case RuleItemType of
        ritTerminal: Result := '"' + Terminal + '"';
        ritNonTerminal: Result := NonTerminal.Name;
        ritSubItems: begin
          if not Optional and not Repetitive then
            Result := '(' + SubItems.ExportAsString(Notation) + ')'
            else Result := SubItems.ExportAsString(Notation);
        end;
        ritTerminalRange: Result := '(' + TerminalFrom + ' .. ' + TerminalTo + ')';
      end;
      if Optional and not Repetitive then Result := '[' + Result + ']';
      if Repetitive then Result := '{' + Result + '}';
      if AnyExcept then Result := 'other then ' + Result;
    end;
  end;
end;

constructor TRuleItem.Create;
begin
  SubItems := TRuleItems.Create;
  SubItems.Grammer := Grammer;
end;

destructor TRuleItem.Destroy;
begin
  FreeAndNil(SubItems);
  inherited Destroy;
end;

procedure TRuleItem.SetParentRule(AValue: TRule);
begin
  if FParentRule = AValue then Exit;
  FParentRule := AValue;
  SubItems.ParentRule := AValue;
end;

function TRuleItem.GetCharLength: Integer;
begin
  Result := 0;
  if not Optional then
  case RuleItemType of
    ritTerminal: Result := Length(Terminal);
    //ritNonTerminal: Result := NonTerminal.Items.GetCharLength;
    ritSubItems: Result := SubItems.GetCharLength;
    ritTerminalRange: Result := Max(Length(TerminalFrom), Length(TerminalTo))
  end;
end;

procedure TRuleItem.SetGrammer(AValue: TGrammer);
begin
  if FGrammer = AValue then Exit;
  FGrammer := AValue;
  SubItems.Grammer := AValue;
end;

procedure TRuleItem.LoadFromXmlNode(Node: TDOMNode);
var
  SubItemsNode: TDOMNode;
begin
  RuleItemType := TRuleItemType(ReadInteger(Node, 'Type', Integer(ritTerminal)));
  Optional := ReadBoolean(Node, 'Optional', False);
  Repetitive := ReadBoolean(Node, 'Repetitive', False);
  AnyExcept := ReadBoolean(Node, 'AnyExcept', False);
  EscapedStrings := ReadBoolean(Node, 'EscapedStrings', False);
  case RuleItemType of
    ritTerminal: Terminal := ReadString(Node, 'Terminal', '');
    ritNonTerminal: NonTerminalName := ReadString(Node, 'NonTerminal', '');
    ritSubItems: begin
      SubItemsNode := Node.FindNode('SubItems');
      if Assigned(SubItemsNode) then SubItems.LoadFromXmlNode(SubItemsNode);
    end;
    ritTerminalRange: begin
      TerminalFrom := ReadString(Node, 'TerminalFrom', '');
      TerminalTo := ReadString(Node, 'TerminalTo', '');
    end;
  end;
  LookupTableUsed := ReadBoolean(Node, 'LookupTableUsed', False);
  LookupTableName := ReadString(Node, 'LookupTable', '');
  LookupTableAction := TLookupTableAction(ReadInteger(Node, 'LookupTableAction', 0));
end;

{ TRuleItems }

procedure TRuleItems.SaveToXmlNode(Node: TDOMNode);
var
  RuleItem: TRuleItem;
  RuleItemNode: TDOMNode;
begin
  WriteInteger(Node, 'Type', Integer(RuleType));
  WriteBoolean(Node, 'WithWhiteSpaces', WithWhiteSpeaces);

  for RuleItem in Self do begin
    RuleItemNode := Node.OwnerDocument.CreateElement('RuleItem');
    RuleItem.SaveToXmlNode(RuleItemNode);
    Node.AppendChild(RuleItemNode);
  end;
end;

procedure TRuleItems.UpdateRuleReference;
var
  RuleItem: TRuleItem;
begin
  for RuleItem in Self do begin
    case RuleItem.RuleItemType of
      ritNonTerminal: RuleItem.NonTerminal := Grammer.Rules.FindName(RuleItem.NonTerminalName);
      ritSubItems: RuleItem.SubItems.UpdateRuleReference;
    end;
    RuleItem.LookupTable := Grammer.LookupTables.FindName(RuleItem.LookupTableName);
  end;
end;

function TRuleItems.GetString: string;
var
  Item: TRuleItem;
begin
  Result := '';
  for Item in Self do begin
    if Item <> First then begin
      if RuleType = rtAnd then Result := Result + ' '
      else if RuleType = rtOr then Result := Result + ' | ';
    end;
    Result := Result + Item.GetString;
  end;
end;

function TRuleItems.ExportAsString(Notation: TGrammerNotation): string;
var
  Item: TRuleItem;
begin
  Result := '';
  for Item in Self do begin
    if Item <> First then begin
      if RuleType = rtAnd then begin
        case Notation of
          gnBnf: Result := Result + ' ';
          gnEbnf: Result := Result + ', ';
        end;
      end else
      if RuleType = rtOr then begin
        case Notation of
          gnBnf: Result := Result + ' | ';
          gnEbnf: Result := Result + ' | ';
        end;
      end;
    end;
    Result := Result + Item.ExportAsString(Notation);
  end;
end;

procedure TRuleItems.SetParentRule(AValue: TRule);
begin
  if FParentRule = AValue then Exit;
  FParentRule := AValue;
end;

function TRuleItems.GetCharLength: Integer;
var
  Item: TRuleItem;
begin
  Result := 0;
  if RuleType = rtOr then begin
    for Item in Self do
      Result := Max(Result, Item.GetCharLength);
  end else
  if RuleType = rtAnd then begin
    for Item in Self do
      Result := Result + Item.GetCharLength;
  end;
end;

procedure TRuleItems.LoadFromXmlNode(Node: TDOMNode);
var
  RuleItemNode: TDOMNode;
  RuleItem: TRuleItem;
begin
  RuleType := TRuleType(ReadInteger(Node, 'Type', Integer(rtAnd)));
  WithWhiteSpeaces := ReadBoolean(Node, 'WithWhiteSpaces', False);

  RuleItemNode := Node.FirstChild;
  while Assigned(RuleItemNode) do begin
    if RuleItemNode.NodeName = 'RuleItem' then begin
      RuleItem := TRuleItem.Create;
      RuleItem.Grammer := Grammer;
      RuleItem.ParentRule := ParentRule;
      RuleItem.LoadFromXmlNode(RuleItemNode);
      Add(RuleItem);
    end;
    RuleItemNode := RuleItemNode.NextSibling;
  end;
end;

{ TRule }

procedure TRule.SaveToXmlNode(Node: TDOMNode);
var
  RuleItemsNode: TDOMNode;
begin
  WriteString(Node, 'Name', Name);
  WriteBoolean(Node, 'CreateSourceNode', CreateSourceNode);
  WriteInteger(Node, 'Level', Integer(Level));

  RuleItemsNode := Node.OwnerDocument.CreateElement('RuleItems');
  Node.AppendChild(RuleItemsNode);
  Items.SaveToXmlNode(RuleItemsNode);
end;

function TRule.GetString: string;
begin
  Result := Name + ' ::= ' + Items.GetString;
end;

function TRule.ExportAsString(Notation: TGrammerNotation): string;
begin
  case Notation of
    gnBnf: Result := Name + ' ::= ' + Items.ExportAsString(Notation);
    gnEbnf: Result := Name + ' = ' + Items.ExportAsString(Notation);
  end;
end;

procedure TRule.SetGrammer(AValue: TGrammer);
begin
  if FGrammer = AValue then Exit;
  FGrammer := AValue;
  Items.Grammer := AValue;
end;

constructor TRule.Create;
begin
  Items := TRuleItems.Create;
  Items.ParentRule := Self;
  Links := TRuleLinks.Create;
end;

destructor TRule.Destroy;
begin
  FreeAndNil(Links);
  FreeAndNil(Items);
  inherited Destroy;
end;

procedure TRule.GetUsedByRule(RefRule: TRule; UsedByRules: TStrings);
var
  Item: TRuleItem;
begin
  for Item in Items do
    if (Item.RuleItemType = ritNonTerminal) and
      (Item.NonTerminal = RefRule) and
      (UsedByRules.IndexOf(Item.ParentRule.Name) = -1) then
      UsedByRules.AddObject(Item.ParentRule.Name, Item.ParentRule);
end;

procedure TRule.LoadFromXmlNode(Node: TDOMNode);
var
  ItemsNode: TDOMNode;
begin
  Name := ReadString(Node, 'Name', '');
  CreateSourceNode := ReadBoolean(Node, 'CreateSourceNode', False);
  Level := TRuleLevel(ReadInteger(Node, 'Level', 0));

  ItemsNode := Node.FindNode('RuleItems');
  if Assigned(ItemsNode) then begin
    Items.LoadFromXmlNode(ItemsNode);
  end;
end;

{ TRules }

procedure TRules.SaveToXmlNode(Node: TDOMNode);
var
  Rule: TRule;
  RuleNode: TDOMNode;
begin
  for Rule in Self do begin
    RuleNode := Node.OwnerDocument.CreateElement('Rule');
    Rule.SaveToXmlNode(RuleNode);
    Node.AppendChild(RuleNode);
  end;
end;

function TRules.FindName(Name: string): TRule;
var
  I: Integer;
begin
  I := 0;
  while (I < Count) and (Items[I].Name <> Name) do Inc(I);
  if I < Count then Result := Items[I]
    else Result := nil;
end;

procedure TRules.LoadFromXmlNode(Node: TDOMNode);
var
  RuleNode: TDOMNode;
  Rule: TRule;
begin
  RuleNode := Node.FirstChild;
  while Assigned(RuleNode) do begin
    if RuleNode.NodeName = 'Rule' then begin
      Rule := TRule.Create;
      Rule.Grammer := Grammer;
      Rule.LoadFromXmlNode(RuleNode);
      Add(Rule);
    end;
    RuleNode := RuleNode.NextSibling;
  end;
end;

function TRules.GetString: string;
var
  Rule: TRule;
begin
  Result := '';
  for Rule in Self do begin
    Result := Result + Rule.GetString + LineEnding;
  end;
end;

function TRules.ExportAsString(Notation: TGrammerNotation): string;
var
  Rule: TRule;
begin
  Result := '';
  for Rule in Self do begin
    Result := Result + Rule.ExportAsString(Notation) + LineEnding;
  end;
end;

end.