source: trunk/IDE/UProducerTreeView.pas

unit UProducerTreeView;

interface

uses
  Classes, SysUtils, SourceCode, ComCtrls, Producer, StrUtils;

type

  { TProducerTreeView }

  TProducerTreeView = class(TProducer)
  private
    procedure AddNodeAssignment(Node: TTreeNode; Assignment: TAssignment);
    procedure AddNodeBeginEnd(Node: TTreeNode; BeginEnd: TBeginEnd);
    procedure AddNodeIfThenElse(Node: TTreeNode; IfThenElse: TIfThenElse);
    procedure AddNodeMethodCall(Node: TTreeNode; Method: TFunctionCall);
    procedure AddNodeMethodList(Node: TTreeNode; Methods: TFunctionList);
    procedure AddNodeParameterList(Node: TTreeNode; Parameters: TParameterList);
    procedure AddNodeTypeRecord(Node: TTreeNode; TypeRecord: TTypeRecord);
    procedure AddNodeTypeList(Node: TTreeNode; Types: TTypeList);
    procedure AddNodeType(Node: TTreeNode; AType: TType);
    procedure AddNodeVariableList(Node: TTreeNode; Variables: TVariableList);
    procedure AddNodeConstantList(Node: TTreeNode; Constants: TConstantList);
    procedure AddNodeModule(Node: TTreeNode; Module: TModule);
    procedure AddNodeUses(Node: TTreeNode; UsedModuleList: TUsedModuleList);
    procedure AddNodeProgram(Node: TTreeNode; Code: TProgram);
    procedure AddNodeWhileDo(Node: TTreeNode; WhileDo: TWhileDo);
    procedure AddNodeForToDo(Node: TTreeNode; ForToDo: TForToDo);
    procedure AddNodeCommand(Node: TTreeNode; Command: TCommand);
    procedure AddNodeExpression(Node: TTreeNode; Expression: TExpression);
    procedure WriteNode(Target: TStringList; Node: TTreeNode; Indetation: Integer);
  public
    TreeView: TTreeView;
    procedure AssignToStringList(Target: TStringList); override;
    procedure Produce(Module: TModule); override;
    constructor Create;
    destructor Destroy; override;
  end;

implementation

{ TProducerTreeView }

procedure TProducerTreeView.AddNodeBeginEnd(Node: TTreeNode;
  BeginEnd: TBeginEnd);
var
  NewNode: TTreeNode;
  NewNode2: TTreeNode;
  I: Integer;
begin
  NewNode := TreeView.Items.AddChild(Node, 'begin-end');
  for I := 0 to BeginEnd.Commands.Count - 1 do
  AddNodeCommand(NewNode, TCommand(BeginEnd.Commands[I]));
end;

procedure TProducerTreeView.AddNodeWhileDo(Node: TTreeNode; WhileDo: TWhileDo);
var
  NewNode: TTreeNode;
  NewNode2: TTreeNode;
begin
  NewNode := TreeView.Items.AddChild(Node, 'while');
  NewNode2 := TreeView.Items.AddChild(NewNode, 'condition');
  AddNodeExpression(NewNode2, WhileDo.Condition);
  NewNode2 := TreeView.Items.AddChild(NewNode, 'do');
  AddNodeCommand(NewNode2, WhileDo.Command);
end;

procedure TProducerTreeView.AddNodeForToDo(Node: TTreeNode; ForToDo: TForToDo);
var
  NewNode: TTreeNode;
  NewNode2: TTreeNode;
  NewNode3: TTreeNode;
  I: Integer;
begin
  with ForToDo do begin
    NewNode := TreeView.Items.AddChild(Node, 'for');
    NewNode2 := TreeView.Items.AddChild(NewNode, 'control');
    if Assigned(ControlVariable) then
      NewNode3 := TreeView.Items.AddChild(NewNode2, ControlVariable.Name);
    NewNode2 := TreeView.Items.AddChild(NewNode, 'from');
    AddNodeExpression(NewNode2, Start);
    NewNode2 := TreeView.Items.AddChild(NewNode, 'to');
    AddNodeExpression(NewNode2, Stop);
    NewNode2 := TreeView.Items.AddChild(NewNode, 'do');
    AddNodeCommand(NewNode2, Command);
  end;
end;

procedure TProducerTreeView.AddNodeIfThenElse(Node: TTreeNode; IfThenElse: TIfThenElse);
var
  NewNode: TTreeNode;
  NewNode2: TTreeNode;
  NewNode3: TTreeNode;
  I: Integer;
begin
  NewNode := TreeView.Items.AddChild(Node, 'if');
  NewNode2 := TreeView.Items.AddChild(NewNode, 'condition');
  AddNodeExpression(NewNode2, IfThenElse.Condition);
  NewNode2 := TreeView.Items.AddChild(NewNode, 'then');
  AddNodeCommand(NewNode2, IfThenElse.Command);
  if Assigned(IfThenElse.ElseCommand) then begin
    NewNode2 := TreeView.Items.AddChild(NewNode, 'else');
    AddNodeCommand(NewNode2, IfThenElse.ElseCommand);
  end;
end;

procedure TProducerTreeView.AddNodeMethodCall(Node: TTreeNode; Method: TFunctionCall);
var
  NewNode: TTreeNode;
begin
  NewNode := TreeView.Items.AddChild(Node, Method.FunctionRef.Name);
end;

procedure TProducerTreeView.AddNodeAssignment(Node: TTreeNode; Assignment: TAssignment);
var
  NewNode: TTreeNode;
begin
  NewNode := TreeView.Items.AddChild(Node, Assignment.Target.Name + ' := ');
  AddNodeExpression(NewNode, Assignment.Source);
end;

procedure TProducerTreeView.AddNodeCommand(Node: TTreeNode; Command: TCommand);
begin
  if Command is TBeginEnd then
    AddNodeBeginEnd(Node, TBeginEnd(Command))
  else
  if Command is TWhileDo then
    AddNodeWhileDo(Node, TWhileDo(Command))
  else
  if Command is TFunctionCall then
    AddNodeMethodCall(Node, TFunctionCall(Command))
  else
  if Command is TIfThenElse then
    AddNodeIfThenElse(Node, TIfThenElse(Command))
  else
  if Command is TForToDo then
    AddNodeForToDo(Node, TForToDo(Command))
  else
  if Command is TAssignment then
    AddNodeAssignment(Node, TAssignment(Command));
end;

procedure TProducerTreeView.AddNodeExpression(Node: TTreeNode; Expression: TExpression
  );
var
  NewNode: TTreeNode;
begin
  case Expression.NodeType of
    ntConstant: NewNode := TreeView.Items.AddChild(Node, Expression.Value);
    ntVariable: NewNode := TreeView.Items.AddChild(Node, Expression.Variable.Name);
    ntFunction: NewNode := TreeView.Items.AddChild(Node, Expression.FunctionCall.FunctionRef.Name);
    ntOperator: begin
      NewNode := TreeView.Items.AddChild(Node, Expression.OperatorName);
      AddNodeExpression(NewNode, TExpression(Expression.SubItems.First));
      AddNodeExpression(NewNode, TExpression(Expression.SubItems.Last));
    end;
    ntNone: ;
  end;
end;

procedure TProducerTreeView.WriteNode(Target: TStringList; Node: TTreeNode;
  Indetation: Integer);
var
  I: Integer;
begin
  if Node.Count > 0 then begin
    Target.Add(DupeString('  ', Indetation) + '<' + Node.Text + '>');
    for I := 0 to Node.Count - 1 do
      WriteNode(Target, Node.Items[I], Indetation + 1);
    Target.Add(DupeString('  ', Indetation) + '</' + Node.Text + '>');
  end else
    Target.Add(DupeString('  ', Indetation) + '<' + Node.Text + '/>');
end;

procedure TProducerTreeView.AssignToStringList(Target: TStringList);
begin
  with Target do begin
    Clear;
    if Assigned(TreeView.TopItem) then
      WriteNode(Target, TreeView.TopItem, 0);
  end;
end;

procedure TProducerTreeView.AddNodeVariableList(Node: TTreeNode;
  Variables: TVariableList);
var
  NewNode: TTreeNode;
  NewNode2: TTreeNode;
  I: Integer;
begin
  if Variables.Count > 0 then begin
    NewNode := TreeView.Items.AddChild(Node, 'var');
    for I := 0 to Variables.Count - 1 do
    with TVariable(Variables[I]) do begin
      NewNode2 := TreeView.Items.AddChild(NewNode, Name + ': ' + ValueType.Name);
    end;
  end;
end;

procedure TProducerTreeView.AddNodeConstantList(Node: TTreeNode;
  Constants: TConstantList);
var
  NewNode: TTreeNode;
  NewNode2: TTreeNode;
  I: Integer;
begin
  if Constants.Count > 0 then begin
    NewNode := TreeView.Items.AddChild(Node, 'const');
    for I := 0 to Constants.Count - 1 do
    with TConstant(Constants[I]) do begin
      NewNode2 := TreeView.Items.AddChild(NewNode, Name + ': ' + ValueType.Name + ' = ' + Value);
    end;
  end;
end;

procedure TProducerTreeView.AddNodeTypeList(Node: TTreeNode;
  Types: TTypeList);
var
  NewNode: TTreeNode;
  I: Integer;
begin
  if Types.Count > 0 then begin
    NewNode := TreeView.Items.AddChild(Node, 'type');
    for I := 0 to Types.Count - 1 do
    with TType(Types[I]) do
    if (not Internal) then AddNodeType(NewNode, TType(Types[I]));
  end;
end;

procedure TProducerTreeView.AddNodeType(Node: TTreeNode; AType: TType);
var
  NewNode: TTreeNode;
  NewNode2: TTreeNode;
begin
  with AType do begin
    if AType is TTypeRecord then begin
      NewNode := TreeView.Items.AddChild(Node, Name + ' = record');
      AddNodeTypeRecord(NewNode, TTypeRecord(AType));
    end else
    if AType is TTypeArray then begin
      NewNode := TreeView.Items.AddChild(Node, Name + ' = array');
      if Assigned(TTypeArray(AType).IndexType) then begin
        NewNode2 := TreeView.Items.AddChild(NewNode, 'Index');
        AddNodeType(NewNode2, TTypeArray(AType).IndexType);
      end;
      if Assigned(TTypeArray(AType).ItemType) then begin
        NewNode2 := TreeView.Items.AddChild(NewNode, 'ItemType');
        AddNodeType(NewNode2, TTypeArray(AType).ItemType);
      end;
    end else if Assigned(UsedType) then
      NewNode := TreeView.Items.AddChild(Node, Name + ' = ' + UsedType.Name)
    else NewNode := TreeView.Items.AddChild(Node, Name);
  end;
end;

procedure TProducerTreeView.AddNodeMethodList(Node: TTreeNode;
  Methods: TFunctionList);
var
  NewNode: TTreeNode;
  I: Integer;
begin
  for I := 0 to Methods.Count - 1 do
  with TFunction(Methods[I]) do
  if (not Internal) then begin
    if FunctionType = ftFunction then
      NewNode := TreeView.Items.AddChild(Node, 'function ' + Name)
      else NewNode := TreeView.Items.AddChild(Node, 'procedure ' + Name);
    AddNodeParameterList(NewNode, Parameters);
    AddNodeMethodList(NewNode, Functions);
    AddNodeConstantList(NewNode, Constants);
    AddNodeVariableList(NewNode, Variables);
    AddNodeTypeList(NewNode, Types);
    AddNodeBeginEnd(NewNode, Code);
  end;
end;

procedure TProducerTreeView.AddNodeParameterList(Node: TTreeNode;
  Parameters: TParameterList);
var
  I: Integer;
  NewNode: TTreeNode;
begin
  if Parameters.Count > 0 then begin
    NewNode := TreeView.Items.AddChild(Node, 'parametery');
    for I := 0 to Parameters.Count - 1 do
    with TParameter(Parameters[I]) do begin
      TreeView.Items.AddChild(NewNode, Name + ': ' + ValueType.Name);
    end;
  end;
end;

procedure TProducerTreeView.AddNodeTypeRecord(Node: TTreeNode; TypeRecord: TTypeRecord
  );
var
  I: Integer;
begin
  if TypeRecord.CommonBlock.Types.Count > 0 then begin
    for I := 0 to TypeRecord.CommonBlock.Types.Count - 1 do
    with TType(TypeRecord.CommonBlock.Types[I]) do
    if not Internal then
      AddNodeType(Node, TType(TypeRecord.CommonBlock.Types[I]));
  end;
end;

procedure TProducerTreeView.AddNodeModule(Node: TTreeNode; Module: TModule);
var
  NewNode: TTreeNode;
  I: Integer;
  TypeName: string;
begin
  if Module is TModulePackage then TypeName := 'package'
  else if Module is TModuleProgram then
  with TModuleProgram(Module) do begin
    TypeName := 'program';
    NewNode := TreeView.Items.AddChild(Node, TypeName + ' ' + Module.Name);
    AddNodeUses(NewNode, UsedModules);
    AddNodeMethodList(NewNode, Body.Functions);
    AddNodeConstantList(NewNode, Body.Constants);
    AddNodeVariableList(NewNode, Body.Variables);
    AddNodeTypeList(NewNode, Body.Types);
    AddNodeBeginEnd(NewNode, Body.Code);
  end else if Module is TModuleUnit then TypeName := 'unit'
  else if Module is TModuleLibrary then TypeName := 'library';

end;

procedure TProducerTreeView.AddNodeUses(Node: TTreeNode;
  UsedModuleList: TUsedModuleList);
var
  NewNode: TTreeNode;
  I: Integer;
begin
  NewNode := TreeView.Items.AddChild(Node, 'uses');
  for I := 0 to UsedModuleList.Count - 1 do begin
    TreeView.Items.AddChild(NewNode, TUsedModule(UsedModuleList[I]).Name);
  end;
end;

procedure TProducerTreeView.AddNodeProgram(Node: TTreeNode; Code: TProgram);
var
  NewNode: TTreeNode;
  I: Integer;
begin
  NewNode := TreeView.Items.AddChild(Node, 'application');
  for I := 0 to Code.Modules.Count - 1 do begin
    AddNodeModule(NewNode, TModule(Code.Modules[I]));
  end;
end;

procedure TProducerTreeView.Produce(Module: TModule);
begin
  with TreeView do begin
    BeginUpdate;
    Items.Clear;
    AddNodeModule(TopItem, Module);
    if Assigned(TopItem) then TopItem.Expand(True);
    EndUpdate;
  end;
end;

constructor TProducerTreeView.Create;
begin
  TreeView := TTreeView.Create(nil);
end;

destructor TProducerTreeView.Destroy;
begin
  TreeView.Free;
  inherited Destroy;
end;

end.