Ast editor unit refactoring
This commit is contained in:
Michael Schimmel
@@ -0,0 +1,706 @@
|
||||
unit Myc.Fmx.AstEditor.Core;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
System.SysUtils,
|
||||
System.Classes,
|
||||
System.UITypes,
|
||||
System.Types,
|
||||
System.Math,
|
||||
System.Math.Vectors,
|
||||
System.Generics.Defaults,
|
||||
System.Generics.Collections,
|
||||
FMX.Types,
|
||||
FMX.Controls,
|
||||
FMX.Objects,
|
||||
FMX.Graphics,
|
||||
FMX.StdCtrls,
|
||||
Myc.Ast.Nodes,
|
||||
Myc.Fmx.AstEditor.Workspace;
|
||||
|
||||
const
|
||||
cNodePadding = 10;
|
||||
cTitleTopPadding = 2;
|
||||
cTitleBottomPadding = 4;
|
||||
cMinNodeWidth = 10;
|
||||
cMinNodeHeight = 10;
|
||||
|
||||
type
|
||||
TAuraNode = class; // Forward declaration
|
||||
|
||||
// This aggregate interface encapsulates all node-specific logic.
|
||||
IAuraNodeHandler = interface
|
||||
// Gets the original logical AST node
|
||||
function GetAstNode: IAstNode;
|
||||
// Creates the specific FMX UI for this node
|
||||
procedure BuildUI(OwnerNode: TAuraNode);
|
||||
// Reconstructs the logical AST node from the FMX UI state
|
||||
function ReconstructAst(OwnerNode: TAuraNode): IAstNode;
|
||||
// The original logical AST node
|
||||
property Node: IAstNode read GetAstNode;
|
||||
end;
|
||||
|
||||
IAstVisualizer = interface
|
||||
{$region 'private'}
|
||||
function GetExprDepth: Integer;
|
||||
function GetParentControl: TControl;
|
||||
function GetWorkspace: TAuraWorkspace;
|
||||
{$endregion}
|
||||
|
||||
function Clone(ParentControl: TControl; ExprDepth: Integer): IAstVisualizer;
|
||||
function CallAccept(const Node: IAstNode): TAuraNode;
|
||||
|
||||
property ExprDepth: Integer read GetExprDepth;
|
||||
property ParentControl: TControl read GetParentControl;
|
||||
property Workspace: TAuraWorkspace read GetWorkspace;
|
||||
end;
|
||||
|
||||
// Defines the layout direction for children within TAutoFitControl
|
||||
TLayoutOrientation = (loVertical, loHorizontal);
|
||||
|
||||
// Defines the alignment of children on the cross-axis
|
||||
TLayoutAlignment = (laCenter, laFlush);
|
||||
|
||||
// A styled control that automatically adjusts its size to fit its children, including padding.
|
||||
TAutoFitControl = class(TStyledControl)
|
||||
private
|
||||
FUpdatingOwnSize: Boolean; // Recursion guard
|
||||
FNeedRecalcSize: Boolean; // Flag for EndUpdate
|
||||
FOrientation: TLayoutOrientation; // Storage for Orientation
|
||||
FAlignment: TLayoutAlignment; // Storage for Alignment
|
||||
procedure RecalcOwnSize;
|
||||
procedure SetOrientation(const Value: TLayoutOrientation);
|
||||
procedure SetAlignment(const Value: TLayoutAlignment);
|
||||
protected
|
||||
procedure ParentContentChanged; override;
|
||||
procedure PaddingChanged; override;
|
||||
procedure ChangeChildren; override;
|
||||
procedure Loaded; override;
|
||||
procedure DoEndUpdate; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
|
||||
published
|
||||
property Padding;
|
||||
property Orientation: TLayoutOrientation read FOrientation write SetOrientation default TLayoutOrientation.loHorizontal;
|
||||
property Alignment: TLayoutAlignment read FAlignment write SetAlignment default TLayoutAlignment.laCenter;
|
||||
end;
|
||||
|
||||
// A movable panel with a custom-painted border. Content (like title) is added externally.
|
||||
TAuraNode = class(TAutoFitControl)
|
||||
private
|
||||
FBackgroundColor: TAlphaColor;
|
||||
FIsDragging: Boolean;
|
||||
FDownPos: TPointF;
|
||||
FBorderColor: TAlphaColor;
|
||||
FBorderWidth: Single;
|
||||
FBorderRadius: Single;
|
||||
FFrameless: Boolean;
|
||||
FVisualizer: IAstVisualizer;
|
||||
FHandler: IAuraNodeHandler;
|
||||
|
||||
// --- Visual State Fields ---
|
||||
FErrorMessage: string;
|
||||
FTypeInfoText: string;
|
||||
|
||||
procedure SetBackgroundColor(const Value: TAlphaColor);
|
||||
procedure SetBorderColor(const Value: TAlphaColor);
|
||||
procedure SetBorderWidth(const Value: Single);
|
||||
procedure SetBorderRadius(const Value: Single);
|
||||
procedure SetFrameless(const Value: Boolean);
|
||||
function GetNode: IAstNode;
|
||||
|
||||
// New Setters
|
||||
procedure SetErrorMessage(const Value: string);
|
||||
procedure SetTypeInfoText(const Value: string);
|
||||
procedure UpdateVisualState;
|
||||
|
||||
protected
|
||||
procedure Paint; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
|
||||
procedure SetupNode;
|
||||
|
||||
public
|
||||
constructor Create(const AVisualizer: IAstVisualizer; const AHandler: IAuraNodeHandler); reintroduce;
|
||||
destructor Destroy; override;
|
||||
|
||||
procedure AfterConstruction; override;
|
||||
|
||||
function AddLabel(Parent: TControl; const Txt: String): TLabel;
|
||||
function AddContainer(Parent: TControl; Orientation: TLayoutOrientation; Alignment: TLayoutAlignment): TAutoFitControl;
|
||||
function AddExpr(Parent: TControl; const Title: String; const Node: IAstNode): TAuraNode;
|
||||
|
||||
function CreateAst: IAstNode;
|
||||
|
||||
property Visualizer: IAstVisualizer read FVisualizer;
|
||||
property Node: IAstNode read GetNode;
|
||||
|
||||
// --- Visual State Properties ---
|
||||
property ErrorMessage: string read FErrorMessage write SetErrorMessage;
|
||||
property TypeInfoText: string read FTypeInfoText write SetTypeInfoText;
|
||||
|
||||
published
|
||||
property BorderColor: TAlphaColor read FBorderColor write SetBorderColor;
|
||||
property BorderWidth: Single read FBorderWidth write SetBorderWidth;
|
||||
property BorderRadius: Single read FBorderRadius write SetBorderRadius;
|
||||
property BackgroundColor: TAlphaColor read FBackgroundColor write SetBackgroundColor;
|
||||
property Frameless: Boolean read FFrameless write SetFrameless;
|
||||
|
||||
property Align;
|
||||
property Anchors;
|
||||
property ClipChildren default True;
|
||||
property Cursor default crDefault;
|
||||
property DragMode default TDragMode.dmManual;
|
||||
property Enabled;
|
||||
property Height;
|
||||
property Hint;
|
||||
property HitTest default True;
|
||||
property Locked;
|
||||
property Margins;
|
||||
property Opacity;
|
||||
property Padding;
|
||||
property PopupMenu;
|
||||
property Position;
|
||||
property RotationAngle;
|
||||
property RotationCenter;
|
||||
property Scale;
|
||||
property Size;
|
||||
property Visible;
|
||||
property Width;
|
||||
property OnClick;
|
||||
property OnDblClick;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseWheel;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
end;
|
||||
|
||||
// Helper base class to reduce boilerplate in specific handlers
|
||||
TBaseNodeHandler<T: IAstNode> = class(TInterfacedObject, IAuraNodeHandler)
|
||||
protected
|
||||
FNode: T;
|
||||
function GetAstNode: IAstNode;
|
||||
public
|
||||
constructor Create(const ANode: T);
|
||||
procedure BuildUI(OwnerNode: TAuraNode); virtual; abstract;
|
||||
function ReconstructAst(OwnerNode: TAuraNode): IAstNode; virtual; abstract;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Myc.Ast;
|
||||
|
||||
{ TAutoFitControl }
|
||||
|
||||
constructor TAutoFitControl.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited Create(AOwner);
|
||||
HitTest := True;
|
||||
FOrientation := TLayoutOrientation.loHorizontal;
|
||||
FAlignment := TLayoutAlignment.laCenter;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.SetAlignment(const Value: TLayoutAlignment);
|
||||
begin
|
||||
if FAlignment <> Value then
|
||||
begin
|
||||
FAlignment := Value;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.SetOrientation(const Value: TLayoutOrientation);
|
||||
begin
|
||||
if FOrientation <> Value then
|
||||
begin
|
||||
FOrientation := Value;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.RecalcOwnSize;
|
||||
var
|
||||
i: Integer;
|
||||
child: TControl;
|
||||
childrenToLayout: TList<TControl>;
|
||||
currentX, currentY: Single;
|
||||
requiredWidth, requiredHeight: Single;
|
||||
childWidthWithMargins, childHeightWithMargins: Single;
|
||||
hasVisibleChild: Boolean;
|
||||
begin
|
||||
if FUpdatingOwnSize then
|
||||
exit;
|
||||
if IsUpdating then
|
||||
begin
|
||||
FNeedRecalcSize := True;
|
||||
exit;
|
||||
end;
|
||||
|
||||
FUpdatingOwnSize := True;
|
||||
childrenToLayout := nil;
|
||||
try
|
||||
requiredWidth := Padding.Left + Padding.Right;
|
||||
requiredHeight := Padding.Top + Padding.Bottom;
|
||||
currentX := Padding.Left;
|
||||
currentY := Padding.Top;
|
||||
hasVisibleChild := False;
|
||||
|
||||
childrenToLayout := TList<TControl>.Create;
|
||||
for i := 0 to ChildrenCount - 1 do
|
||||
begin
|
||||
if Children[i] is TControl then
|
||||
begin
|
||||
child := TControl(Children[i]);
|
||||
if child.Visible and (child.Align = TAlignLayout.None) then
|
||||
begin
|
||||
childrenToLayout.Add(child);
|
||||
hasVisibleChild := True;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
if hasVisibleChild then
|
||||
begin
|
||||
if FOrientation = TLayoutOrientation.loVertical then
|
||||
begin
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
child.Position.Y := currentY + child.Margins.Top;
|
||||
currentY := child.Position.Y + child.Height + child.Margins.Bottom;
|
||||
|
||||
childWidthWithMargins := Padding.Left + child.Margins.Left + child.Width + child.Margins.Right + Padding.Right;
|
||||
requiredWidth := System.Math.Max(requiredWidth, childWidthWithMargins);
|
||||
end;
|
||||
requiredHeight := currentY + Padding.Bottom;
|
||||
|
||||
if FAlignment = TLayoutAlignment.laFlush then
|
||||
begin
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
child.Position.X := Padding.Left + child.Margins.Left;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
var contentWidth := requiredWidth - Padding.Left - Padding.Right;
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
var childTotalWidth := child.Width + child.Margins.Left + child.Margins.Right;
|
||||
var childX := Padding.Left + ((contentWidth - childTotalWidth) / 2) + child.Margins.Left;
|
||||
child.Position.X := childX;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
child.Position.X := currentX + child.Margins.Left;
|
||||
currentX := child.Position.X + child.Width + child.Margins.Right;
|
||||
|
||||
childHeightWithMargins := Padding.Top + child.Margins.Top + child.Height + child.Margins.Bottom + Padding.Bottom;
|
||||
requiredHeight := System.Math.Max(requiredHeight, childHeightWithMargins);
|
||||
end;
|
||||
requiredWidth := currentX + Padding.Right;
|
||||
|
||||
if FAlignment = TLayoutAlignment.laFlush then
|
||||
begin
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
child.Position.Y := Padding.Top + child.Margins.Top;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
var contentHeight := requiredHeight - Padding.Top - Padding.Bottom;
|
||||
for child in childrenToLayout do
|
||||
begin
|
||||
var childTotalHeight := child.Height + child.Margins.Top + child.Margins.Bottom;
|
||||
var childY := Padding.Top + ((contentHeight - childTotalHeight) / 2) + child.Margins.Top;
|
||||
child.Position.Y := childY;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
requiredWidth := Padding.Left + Padding.Right;
|
||||
requiredHeight := Padding.Top + Padding.Bottom;
|
||||
end;
|
||||
|
||||
requiredWidth := System.Math.Max(0, requiredWidth);
|
||||
requiredHeight := System.Math.Max(0, requiredHeight);
|
||||
|
||||
if not SameValue(requiredWidth, Width, TEpsilon.Position) or not SameValue(requiredHeight, Height, TEpsilon.Position) then
|
||||
begin
|
||||
FSize.SetSizeWithoutNotification(TSizeF.Create(requiredWidth, requiredHeight));
|
||||
HandleSizeChanged;
|
||||
end;
|
||||
|
||||
finally
|
||||
childrenToLayout.Free;
|
||||
FUpdatingOwnSize := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.Loaded;
|
||||
begin
|
||||
inherited Loaded;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.ChangeChildren;
|
||||
begin
|
||||
inherited ChangeChildren;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.PaddingChanged;
|
||||
begin
|
||||
inherited PaddingChanged;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.ParentContentChanged;
|
||||
begin
|
||||
inherited ParentContentChanged;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
|
||||
procedure TAutoFitControl.DoEndUpdate;
|
||||
begin
|
||||
inherited;
|
||||
if FNeedRecalcSize then
|
||||
begin
|
||||
FNeedRecalcSize := False;
|
||||
RecalcOwnSize;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ TAuraNode }
|
||||
|
||||
constructor TAuraNode.Create(const AVisualizer: IAstVisualizer; const AHandler: IAuraNodeHandler);
|
||||
begin
|
||||
inherited Create(AVisualizer.Workspace);
|
||||
|
||||
Parent := AVisualizer.ParentControl;
|
||||
|
||||
FVisualizer := AVisualizer.Clone(Self, AVisualizer.ExprDepth);
|
||||
FHandler := AHandler;
|
||||
|
||||
FIsDragging := False;
|
||||
|
||||
FBorderColor := TAlphaColors.Gray;
|
||||
FBorderWidth := 1;
|
||||
FBorderRadius := 9;
|
||||
FBackgroundColor := $080a0a0a;
|
||||
|
||||
FFrameless := False;
|
||||
|
||||
Width := cMinNodeWidth;
|
||||
Height := cMinNodeHeight;
|
||||
|
||||
HitTest := True;
|
||||
ClipChildren := True;
|
||||
|
||||
Margins.Left := 4;
|
||||
Margins.Top := 4;
|
||||
Margins.Right := 4;
|
||||
Margins.Bottom := 4;
|
||||
Padding.Left := 3;
|
||||
Padding.Top := 3;
|
||||
Padding.Right := 3;
|
||||
Padding.Bottom := 3;
|
||||
|
||||
var cn: Cardinal := $ea - (7 * FVisualizer.ExprDepth);
|
||||
var c: Cardinal := $ff000000 or (cn shl 16) or (cn shl 8) or cn;
|
||||
BackgroundColor := c;
|
||||
end;
|
||||
|
||||
destructor TAuraNode.Destroy;
|
||||
begin
|
||||
FHandler := nil;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TAuraNode.AddContainer(Parent: TControl; Orientation: TLayoutOrientation; Alignment: TLayoutAlignment): TAutoFitControl;
|
||||
begin
|
||||
Result := TAutoFitControl.Create(Self);
|
||||
Result.Parent := Parent;
|
||||
Result.Orientation := Orientation;
|
||||
Result.Alignment := Alignment;
|
||||
Result.HitTest := False;
|
||||
end;
|
||||
|
||||
function TAuraNode.AddExpr(Parent: TControl; const Title: String; const Node: IAstNode): TAuraNode;
|
||||
begin
|
||||
var cont := AddContainer(Parent, loHorizontal, laCenter);
|
||||
|
||||
var lbl := AddLabel(cont, Title);
|
||||
lbl.Font.Style := lbl.Font.Style + [TFontStyle.fsBold];
|
||||
|
||||
Result := FVisualizer.Clone(cont, FVisualizer.ExprDepth + 1).CallAccept(Node);
|
||||
end;
|
||||
|
||||
function TAuraNode.AddLabel(Parent: TControl; const Txt: String): TLabel;
|
||||
begin
|
||||
Result := TLabel.Create(Self);
|
||||
Result.Parent := Parent;
|
||||
|
||||
Result.Position.Point := TPoint.Create(cNodePadding, cNodePadding);
|
||||
Result.Margins.Left := cNodePadding;
|
||||
Result.Margins.Right := cNodePadding;
|
||||
Result.Margins.Top := cTitleTopPadding;
|
||||
Result.Margins.Bottom := cTitleBottomPadding;
|
||||
Result.WordWrap := False;
|
||||
Result.AutoSize := True;
|
||||
Result.HitTest := False;
|
||||
|
||||
Result.StyledSettings := Result.StyledSettings - [TStyledSetting.Style];
|
||||
|
||||
Result.Text := Txt;
|
||||
Result.ApplyStyleLookup;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.AfterConstruction;
|
||||
begin
|
||||
inherited;
|
||||
SetupNode;
|
||||
end;
|
||||
|
||||
function TAuraNode.CreateAst: IAstNode;
|
||||
begin
|
||||
if Assigned(FHandler) then
|
||||
Result := FHandler.ReconstructAst(Self)
|
||||
else
|
||||
Result := TAst.Nop;
|
||||
end;
|
||||
|
||||
function TAuraNode.GetNode: IAstNode;
|
||||
begin
|
||||
if Assigned(FHandler) then
|
||||
Result := FHandler.Node
|
||||
else
|
||||
Result := nil;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetErrorMessage(const Value: string);
|
||||
begin
|
||||
if FErrorMessage <> Value then
|
||||
begin
|
||||
FErrorMessage := Value;
|
||||
UpdateVisualState;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetTypeInfoText(const Value: string);
|
||||
begin
|
||||
if FTypeInfoText <> Value then
|
||||
begin
|
||||
FTypeInfoText := Value;
|
||||
UpdateVisualState;
|
||||
// Type Info usually doesn't change painting, just hint
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.UpdateVisualState;
|
||||
begin
|
||||
if FErrorMessage <> '' then
|
||||
begin
|
||||
Hint := 'Error: ' + FErrorMessage;
|
||||
ShowHint := True;
|
||||
end
|
||||
else if FTypeInfoText <> '' then
|
||||
begin
|
||||
Hint := 'Type: ' + FTypeInfoText;
|
||||
ShowHint := True;
|
||||
end
|
||||
else
|
||||
begin
|
||||
Hint := '';
|
||||
ShowHint := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.Paint;
|
||||
var
|
||||
rect: TRectF;
|
||||
effBorderColor: TAlphaColor;
|
||||
effBorderWidth: Single;
|
||||
effDash: TStrokeDash;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
Canvas.Fill.Kind := TBrushKind.None;
|
||||
|
||||
// Determine styles based on state (Error > Standard)
|
||||
if FErrorMessage <> '' then
|
||||
begin
|
||||
effBorderColor := TAlphaColors.Red;
|
||||
effBorderWidth := 2.0;
|
||||
effDash := TStrokeDash.Solid;
|
||||
end
|
||||
else
|
||||
begin
|
||||
effBorderColor := FBorderColor;
|
||||
effBorderWidth := FBorderWidth;
|
||||
if FFrameless then
|
||||
effDash := TStrokeDash.Dot
|
||||
else
|
||||
effDash := TStrokeDash.Solid;
|
||||
end;
|
||||
|
||||
if FFrameless and (FErrorMessage = '') then
|
||||
begin
|
||||
// Standard frameless drawing (only if no error)
|
||||
Canvas.Fill.Kind := TBrushKind.Solid;
|
||||
Canvas.Fill.Color := FBackgroundColor;
|
||||
Canvas.Stroke.Kind := TBrushKind.None;
|
||||
Canvas.FillRect(TRectF.Create(0, 0, Width, Height), 0, 0, [], 1.0);
|
||||
Canvas.Stroke.Kind := TBrushKind.Solid;
|
||||
Canvas.Stroke.Color := effBorderColor;
|
||||
Canvas.Stroke.Thickness := effBorderWidth;
|
||||
Canvas.Stroke.Dash := effDash;
|
||||
Canvas.DrawRect(TRectF.Create(0, 0, Width, Height), 0, 0, [], 1.0);
|
||||
end
|
||||
else
|
||||
begin
|
||||
// Draw background fill first
|
||||
Canvas.Fill.Kind := TBrushKind.Solid;
|
||||
Canvas.Fill.Color := FBackgroundColor;
|
||||
rect := TRectF.Create(0, 0, Width, Height);
|
||||
if (effBorderWidth > 0) then
|
||||
rect.Inflate(-effBorderWidth / 2, -effBorderWidth / 2);
|
||||
Canvas.FillRect(rect, FBorderRadius, FBorderRadius, AllCorners, 1.0, TCornerType.Round);
|
||||
|
||||
// Draw border (Custom or Error)
|
||||
if (effBorderWidth > 0) and (effBorderColor <> TAlphaColors.Null) then
|
||||
begin
|
||||
rect := TRectF.Create(0, 0, Width, Height);
|
||||
rect.Inflate(-effBorderWidth / 2, -effBorderWidth / 2);
|
||||
|
||||
Canvas.Stroke.Kind := TBrushKind.Solid;
|
||||
Canvas.Stroke.Color := effBorderColor;
|
||||
Canvas.Stroke.Thickness := effBorderWidth;
|
||||
Canvas.Stroke.Dash := effDash;
|
||||
Canvas.DrawRect(rect, FBorderRadius, FBorderRadius, AllCorners, 1.0, TCornerType.Round);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetBorderColor(const Value: TAlphaColor);
|
||||
begin
|
||||
if FBorderColor <> Value then
|
||||
begin
|
||||
FBorderColor := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetBorderRadius(const Value: Single);
|
||||
begin
|
||||
if FBorderRadius <> Value then
|
||||
begin
|
||||
FBorderRadius := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetBorderWidth(const Value: Single);
|
||||
begin
|
||||
if FBorderWidth <> Value then
|
||||
begin
|
||||
FBorderWidth := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetFrameless(const Value: Boolean);
|
||||
begin
|
||||
if FFrameless <> Value then
|
||||
begin
|
||||
FFrameless := Value;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if Button = TMouseButton.mbLeft then
|
||||
begin
|
||||
var lControl := ObjectAtPoint(LocalToScreen(TPointF.Create(X, Y)));
|
||||
if Assigned(lControl) and (lControl.GetObject = Self) then
|
||||
begin
|
||||
FIsDragging := True;
|
||||
FDownPos := TPointF.Create(X, Y);
|
||||
Capture;
|
||||
BringToFront;
|
||||
end
|
||||
else
|
||||
FIsDragging := False;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.MouseMove(Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if FIsDragging then
|
||||
begin
|
||||
var deltaX := X - FDownPos.X;
|
||||
var deltaY := Y - FDownPos.Y;
|
||||
|
||||
Position.X := Position.X + deltaX;
|
||||
Position.Y := Position.Y + deltaY;
|
||||
|
||||
if ParentControl <> nil then
|
||||
ParentControl.Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if (Button = TMouseButton.mbLeft) and (FIsDragging) then
|
||||
begin
|
||||
ReleaseCapture;
|
||||
FIsDragging := False;
|
||||
if ParentControl <> nil then
|
||||
ParentControl.Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetBackgroundColor(const Value: TAlphaColor);
|
||||
begin
|
||||
FBackgroundColor := Value;
|
||||
Repaint;
|
||||
end;
|
||||
|
||||
procedure TAuraNode.SetupNode;
|
||||
begin
|
||||
if Assigned(FHandler) then
|
||||
FHandler.BuildUI(Self);
|
||||
end;
|
||||
|
||||
{ TBaseNodeHandler<T> }
|
||||
|
||||
constructor TBaseNodeHandler<T>.Create(const ANode: T);
|
||||
begin
|
||||
inherited Create;
|
||||
FNode := ANode;
|
||||
end;
|
||||
|
||||
function TBaseNodeHandler<T>.GetAstNode: IAstNode;
|
||||
begin
|
||||
Result := FNode;
|
||||
end;
|
||||
|
||||
end.
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,249 @@
|
||||
unit Myc.Fmx.AstEditor.Visualizer;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
System.SysUtils,
|
||||
System.Classes,
|
||||
FMX.Controls,
|
||||
Myc.Data.Value,
|
||||
Myc.Ast.Nodes,
|
||||
Myc.Ast.Visitor,
|
||||
Myc.Fmx.AstEditor.Workspace,
|
||||
Myc.Fmx.AstEditor.Core,
|
||||
Myc.Fmx.AstEditor.Handlers;
|
||||
|
||||
type
|
||||
// Inherits from the generic TAstVisitor<TAuraNode>
|
||||
TAstVisualizer = class(TAstVisitor<TAuraNode>, IAstVisualizer)
|
||||
private
|
||||
FExprDepth: Integer;
|
||||
FParentControl: TControl;
|
||||
FWorkspace: TAuraWorkspace;
|
||||
function CallAccept(const Node: IAstNode): TAuraNode;
|
||||
function GetExprDepth: Integer;
|
||||
function GetParentControl: TControl;
|
||||
function GetWorkspace: TAuraWorkspace;
|
||||
procedure SetExprDepth(const Value: Integer);
|
||||
procedure SetParentControl(const Value: TControl);
|
||||
protected
|
||||
// Visitor implementations for each AST node type.
|
||||
function VisitConstant(const Node: IConstantNode): TAuraNode; override;
|
||||
function VisitIdentifier(const Node: IIdentifierNode): TAuraNode; override;
|
||||
function VisitKeyword(const Node: IKeywordNode): TAuraNode; override;
|
||||
function VisitIfExpression(const Node: IIfExpressionNode): TAuraNode; override;
|
||||
function VisitTernaryExpression(const Node: ITernaryExpressionNode): TAuraNode; override;
|
||||
function VisitLambdaExpression(const Node: ILambdaExpressionNode): TAuraNode; override;
|
||||
function VisitFunctionCall(const Node: IFunctionCallNode): TAuraNode; override;
|
||||
function VisitMacroExpansionNode(const Node: IMacroExpansionNode): TAuraNode; override;
|
||||
function VisitBlockExpression(const Node: IBlockExpressionNode): TAuraNode; override;
|
||||
function VisitVariableDeclaration(const Node: IVariableDeclarationNode): TAuraNode; override;
|
||||
function VisitAssignment(const Node: IAssignmentNode): TAuraNode; override;
|
||||
function VisitMacroDefinition(const Node: IMacroDefinitionNode): TAuraNode; override;
|
||||
function VisitQuasiquote(const Node: IQuasiquoteNode): TAuraNode; override;
|
||||
function VisitUnquote(const Node: IUnquoteNode): TAuraNode; override;
|
||||
function VisitUnquoteSplicing(const Node: IUnquoteSplicingNode): TAuraNode; override;
|
||||
function VisitIndexer(const Node: IIndexerNode): TAuraNode; override;
|
||||
function VisitMemberAccess(const Node: IMemberAccessNode): TAuraNode; override;
|
||||
function VisitRecordLiteral(const Node: IRecordLiteralNode): TAuraNode; override;
|
||||
function VisitCreateSeries(const Node: ICreateSeriesNode): TAuraNode; override;
|
||||
function VisitAddSeriesItem(const Node: IAddSeriesItemNode): TAuraNode; override;
|
||||
function VisitSeriesLength(const Node: ISeriesLengthNode): TAuraNode; override;
|
||||
function VisitRecurNode(const Node: IRecurNode): TAuraNode; override;
|
||||
function VisitNop(const Node: INopNode): TAuraNode; override;
|
||||
|
||||
public
|
||||
constructor Create(AWorkspace: TAuraWorkspace; AParentControl: TControl; AExprDepth: Integer);
|
||||
destructor Destroy; override;
|
||||
|
||||
function Clone(ParentControl: TControl; ExprDepth: Integer): IAstVisualizer;
|
||||
|
||||
property ExprDepth: Integer read GetExprDepth write SetExprDepth;
|
||||
property ParentControl: TControl read GetParentControl write SetParentControl;
|
||||
property Workspace: TAuraWorkspace read GetWorkspace;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ TAstVisualizer }
|
||||
|
||||
constructor TAstVisualizer.Create(AWorkspace: TAuraWorkspace; AParentControl: TControl; AExprDepth: Integer);
|
||||
begin
|
||||
inherited Create;
|
||||
FWorkspace := AWorkspace;
|
||||
FParentControl := AParentControl;
|
||||
FExprDepth := AExprDepth;
|
||||
end;
|
||||
|
||||
destructor TAstVisualizer.Destroy;
|
||||
begin
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TAstVisualizer.CallAccept(const Node: IAstNode): TAuraNode;
|
||||
var
|
||||
dataValue: TDataValue;
|
||||
begin
|
||||
if not Assigned(Node) then
|
||||
exit(nil);
|
||||
|
||||
dataValue := Node.Accept(Self);
|
||||
|
||||
if dataValue.Kind = TDataValueKind.vkGeneric then
|
||||
begin
|
||||
Result := dataValue.AsGeneric<TAuraNode>;
|
||||
end
|
||||
else
|
||||
begin
|
||||
Result := nil;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TAstVisualizer.Clone(ParentControl: TControl; ExprDepth: Integer): IAstVisualizer;
|
||||
begin
|
||||
Result := TAstVisualizer.Create(FWorkspace, ParentControl, ExprDepth);
|
||||
end;
|
||||
|
||||
function TAstVisualizer.GetExprDepth: Integer;
|
||||
begin
|
||||
Result := FExprDepth;
|
||||
end;
|
||||
|
||||
function TAstVisualizer.GetParentControl: TControl;
|
||||
begin
|
||||
Result := FParentControl;
|
||||
end;
|
||||
|
||||
function TAstVisualizer.GetWorkspace: TAuraWorkspace;
|
||||
begin
|
||||
Result := FWorkspace;
|
||||
end;
|
||||
|
||||
procedure TAstVisualizer.SetExprDepth(const Value: Integer);
|
||||
begin
|
||||
FExprDepth := Value;
|
||||
end;
|
||||
|
||||
procedure TAstVisualizer.SetParentControl(const Value: TControl);
|
||||
begin
|
||||
FParentControl := Value;
|
||||
end;
|
||||
|
||||
// --- Visitor Implementations ---
|
||||
|
||||
function TAstVisualizer.VisitConstant(const Node: IConstantNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TConstantNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitIdentifier(const Node: IIdentifierNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TIdentifierNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitKeyword(const Node: IKeywordNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TKeywordNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitBlockExpression(const Node: IBlockExpressionNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TBlockExpressionNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitIfExpression(const Node: IIfExpressionNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TIfExpressionNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitTernaryExpression(const Node: ITernaryExpressionNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TTernaryExpressionNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitLambdaExpression(const Node: ILambdaExpressionNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TLambdaExpressionNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitFunctionCall(const Node: IFunctionCallNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TFunctionCallNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitMacroExpansionNode(const Node: IMacroExpansionNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TMacroExpansionNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitVariableDeclaration(const Node: IVariableDeclarationNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TVariableDeclarationNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitAssignment(const Node: IAssignmentNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TAssignmentNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitMacroDefinition(const Node: IMacroDefinitionNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TMacroDefinitionNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitQuasiquote(const Node: IQuasiquoteNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TQuasiquoteNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitUnquote(const Node: IUnquoteNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TUnquoteNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitUnquoteSplicing(const Node: IUnquoteSplicingNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TUnquoteSplicingNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitIndexer(const Node: IIndexerNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TIndexerNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitMemberAccess(const Node: IMemberAccessNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TMemberAccessNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitRecordLiteral(const Node: IRecordLiteralNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TRecordLiteralNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitCreateSeries(const Node: ICreateSeriesNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TCreateSeriesNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitAddSeriesItem(const Node: IAddSeriesItemNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TAddSeriesItemNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitSeriesLength(const Node: ISeriesLengthNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TSeriesLengthNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitRecurNode(const Node: IRecurNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TRecurNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
function TAstVisualizer.VisitNop(const Node: INopNode): TAuraNode;
|
||||
begin
|
||||
Result := TAuraNode.Create(Self, TNopNodeHandler.Create(Node));
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -0,0 +1,248 @@
|
||||
unit Myc.Fmx.AstEditor.Workspace;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
System.SysUtils,
|
||||
System.Classes,
|
||||
System.Types,
|
||||
System.UITypes,
|
||||
System.Math.Vectors,
|
||||
System.Generics.Collections,
|
||||
FMX.Types,
|
||||
FMX.Controls,
|
||||
FMX.Graphics,
|
||||
FMX.Objects,
|
||||
Myc.Ast,
|
||||
Myc.Ast.Nodes,
|
||||
Myc.Ast.Scope,
|
||||
Myc.Ast.Compiler.Binder;
|
||||
|
||||
const
|
||||
cDataPinColor = TAlphaColors.Dodgerblue;
|
||||
cExecPinColor = TAlphaColors.Lightgreen;
|
||||
|
||||
type
|
||||
TPinConnection = record
|
||||
OutputPin: TControl;
|
||||
InputPin: TControl;
|
||||
constructor Create(AOutputPin, AInputPin: TControl);
|
||||
end;
|
||||
|
||||
TAuraWorkspace = class(TStyledControl)
|
||||
private
|
||||
FConnections: TArray<TPinConnection>;
|
||||
FPanning: TSizeF;
|
||||
FIsPanning: Boolean;
|
||||
FLastPanPos: TPointF;
|
||||
FZoom: Single;
|
||||
protected
|
||||
procedure Paint; override;
|
||||
procedure DoDeleteChildren; override;
|
||||
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
|
||||
procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
|
||||
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
|
||||
procedure MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean); override;
|
||||
procedure DblClick; override;
|
||||
public
|
||||
constructor Create(AOwner: TComponent); override;
|
||||
procedure Build(const RootNode: IAstNode; const Position: TPointF);
|
||||
function GetChildrenMatrix(var Matrix: TMatrix; var Simple: Boolean): Boolean; override;
|
||||
function Zoom(Factor: Single): Boolean;
|
||||
|
||||
published
|
||||
property Align;
|
||||
property Anchors;
|
||||
property ClipChildren default True;
|
||||
property Cursor default crDefault;
|
||||
property DragMode default TDragMode.dmManual;
|
||||
property Enabled;
|
||||
property Height;
|
||||
property HelpContext;
|
||||
property HelpKeyword;
|
||||
property HelpType;
|
||||
property Hint;
|
||||
property HitTest default True;
|
||||
property Locked;
|
||||
property Margins;
|
||||
property Opacity;
|
||||
property Padding;
|
||||
property PopupMenu;
|
||||
property Position;
|
||||
property RotationAngle;
|
||||
property RotationCenter;
|
||||
property Scale;
|
||||
property Size;
|
||||
property StyleLookup;
|
||||
property Visible;
|
||||
property Width;
|
||||
property OnClick;
|
||||
property OnDblClick;
|
||||
property OnMouseDown;
|
||||
property OnMouseMove;
|
||||
property OnMouseUp;
|
||||
property OnMouseWheel;
|
||||
property OnMouseEnter;
|
||||
property OnMouseLeave;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
System.Math,
|
||||
FMX.Platform,
|
||||
Myc.Fmx.AstEditor.Core,
|
||||
Myc.Fmx.AstEditor.Visualizer;
|
||||
|
||||
{ TPinConnection }
|
||||
|
||||
constructor TPinConnection.Create(AOutputPin, AInputPin: TControl);
|
||||
begin
|
||||
OutputPin := AOutputPin;
|
||||
InputPin := AInputPin;
|
||||
end;
|
||||
|
||||
{ TAuraWorkspace }
|
||||
|
||||
constructor TAuraWorkspace.Create(AOwner: TComponent);
|
||||
begin
|
||||
inherited;
|
||||
FZoom := 1.0;
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.Build(const RootNode: IAstNode; const Position: TPointF);
|
||||
begin
|
||||
var visu := TAstVisualizer.Create(Self, Self, 0) as IAstVisualizer;
|
||||
var node := visu.CallAccept(RootNode);
|
||||
|
||||
if Assigned(node) then
|
||||
node.Position.Point := Position;
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.DoDeleteChildren;
|
||||
begin
|
||||
FConnections := nil;
|
||||
inherited;
|
||||
end;
|
||||
|
||||
function TAuraWorkspace.GetChildrenMatrix(var Matrix: TMatrix; var Simple: Boolean): Boolean;
|
||||
begin
|
||||
Matrix := TMatrix.CreateScaling(FZoom, FZoom) * TMatrix.CreateTranslation(FPanning.cx, FPanning.cy);
|
||||
Simple := (FZoom = 1.0) and (FPanning.cx = 0) and (FPanning.cy = 0);
|
||||
Result := True;
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if (Button = TMouseButton.mbLeft) and (ObjectAtPoint(LocalToScreen(TPointF.Create(X, Y))) = Self as IControl) then
|
||||
begin
|
||||
FIsPanning := True;
|
||||
FLastPanPos := TPointF.Create(X, Y);
|
||||
Cursor := crHandPoint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.MouseMove(Shift: TShiftState; X, Y: Single);
|
||||
var
|
||||
delta: TPointF;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
if FIsPanning then
|
||||
begin
|
||||
delta := TPointF.Create(X - FLastPanPos.X, Y - FLastPanPos.Y);
|
||||
FPanning.cx := FPanning.cx + delta.X;
|
||||
FPanning.cy := FPanning.cy + delta.Y;
|
||||
FLastPanPos := TPointF.Create(X, Y);
|
||||
RecalcAbsolute;
|
||||
RecalcUpdateRect;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
|
||||
begin
|
||||
inherited;
|
||||
if (Button = TMouseButton.mbLeft) and (FIsPanning) then
|
||||
begin
|
||||
FIsPanning := False;
|
||||
Cursor := crDefault;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.MouseWheel(Shift: TShiftState; WheelDelta: Integer; var Handled: Boolean);
|
||||
begin
|
||||
inherited;
|
||||
Handled := Zoom(IfThen(WheelDelta > 0, FZoom * 1.1, FZoom / 1.1));
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.DblClick;
|
||||
begin
|
||||
inherited;
|
||||
Zoom(1.0);
|
||||
end;
|
||||
|
||||
procedure TAuraWorkspace.Paint;
|
||||
var
|
||||
connection: TPinConnection;
|
||||
startPoint, endPoint, pinCenter: TPointF;
|
||||
path: TPathData;
|
||||
controlPoint1, controlPoint2: TPointF;
|
||||
controlOffset: Single;
|
||||
begin
|
||||
inherited;
|
||||
|
||||
Canvas.Stroke.Kind := TBrushKind.Solid;
|
||||
Canvas.Stroke.Thickness := 2;
|
||||
|
||||
for connection in FConnections do
|
||||
begin
|
||||
pinCenter := TPointF.Create(connection.OutputPin.Width / 2, connection.OutputPin.Height / 2);
|
||||
var absoluteStart := connection.OutputPin.LocalToAbsolute(pinCenter);
|
||||
|
||||
pinCenter := TPointF.Create(connection.InputPin.Width / 2, connection.InputPin.Height / 2);
|
||||
var absoluteEnd := connection.InputPin.LocalToAbsolute(pinCenter);
|
||||
|
||||
startPoint := AbsoluteToLocal(absoluteStart);
|
||||
endPoint := AbsoluteToLocal(absoluteEnd);
|
||||
|
||||
var str := connection.InputPin.TagString;
|
||||
if Pos('data', str) = 0 then
|
||||
Canvas.Stroke.Color := cExecPinColor
|
||||
else
|
||||
Canvas.Stroke.Color := cDataPinColor;
|
||||
|
||||
path := TPathData.Create;
|
||||
try
|
||||
controlOffset := max(25, 0.5 * endPoint.Distance(startPoint));
|
||||
controlPoint1 := TPointF.Create(startPoint.X + controlOffset, startPoint.Y);
|
||||
controlPoint2 := TPointF.Create(endPoint.X - controlOffset, endPoint.Y);
|
||||
path.MoveTo(startPoint);
|
||||
path.CurveTo(controlPoint1, controlPoint2, endPoint);
|
||||
Canvas.DrawPath(path, 1.0);
|
||||
finally
|
||||
path.Free;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TAuraWorkspace.Zoom(Factor: Single): Boolean;
|
||||
var
|
||||
mouseService: IFMXMouseService;
|
||||
begin
|
||||
Result := TPlatformServices.Current.SupportsPlatformService(IFMXMouseService, mouseService);
|
||||
if Result then
|
||||
begin
|
||||
var mousePos := ScreenToLocal(mouseService.GetMousePos);
|
||||
Factor := Max(0.2, Min(3.0, Factor));
|
||||
FPanning.cx := mousePos.X * (1 - Factor / FZoom) + FPanning.cx * (Factor / FZoom);
|
||||
FPanning.cy := mousePos.Y * (1 - Factor / FZoom) + FPanning.cy * (Factor / FZoom);
|
||||
FZoom := Factor;
|
||||
RecalcAbsolute;
|
||||
RecalcUpdateRect;
|
||||
Repaint;
|
||||
end;
|
||||
end;
|
||||
|
||||
end.
|
||||
@@ -1,369 +0,0 @@
|
||||
unit Test.Myc.Ast.Compiler.Binder;
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
DUnitX.TestFramework,
|
||||
System.SysUtils,
|
||||
System.Generics.Collections,
|
||||
Myc.Ast,
|
||||
Myc.Ast.Nodes,
|
||||
Myc.Ast.Scope,
|
||||
Myc.Ast.Compiler.Binder,
|
||||
Myc.Ast.Types;
|
||||
|
||||
type
|
||||
[TestFixture]
|
||||
TTestAstBinder = class
|
||||
private
|
||||
FRootLayout: IScopeLayout;
|
||||
|
||||
// Updated Bind helper: Returns log to allow assertions on errors
|
||||
function Bind(const Node: IAstNode; out Layout: IScopeLayout; out Log: ICompilerLog): IAstNode;
|
||||
function Unwrap(const Node: IAstNode): IAstNode;
|
||||
public
|
||||
[Setup]
|
||||
procedure Setup;
|
||||
|
||||
// --- Basic Scope & Definitions ---
|
||||
|
||||
[Test]
|
||||
[IgnoreMemoryLeaks]
|
||||
procedure Test_DefineAndResolve_LocalVariable;
|
||||
|
||||
[Test]
|
||||
procedure Test_Shadowing_InnerScopeHidesOuter;
|
||||
|
||||
[Test]
|
||||
[IgnoreMemoryLeaks]
|
||||
procedure Test_ScopeIsolation_SiblingScopesCannotSeeEachOther;
|
||||
|
||||
[Test]
|
||||
[IgnoreMemoryLeaks]
|
||||
procedure Test_Initializer_CanSeeOuterScope_ButNotSelf;
|
||||
|
||||
// --- Parameters ---
|
||||
|
||||
[Test]
|
||||
procedure Test_LambdaParameters_AreBoundToSlotsStartingAtOne;
|
||||
|
||||
[Test]
|
||||
procedure Test_MultipleParameters_AreBoundCorrectly;
|
||||
|
||||
// --- Upvalues / Closures ---
|
||||
|
||||
[Test]
|
||||
procedure Test_Capture_ImmediateParent;
|
||||
|
||||
[Test]
|
||||
procedure Test_Capture_GrandParent_PropagatesThroughIntermediateScope;
|
||||
|
||||
[Test]
|
||||
procedure Test_Self_IsImplicitlyDefinedInLambda;
|
||||
|
||||
// --- Corner Cases & Validation ---
|
||||
|
||||
[TestCase('Valid_Simple', 'x')]
|
||||
[TestCase('Valid_Kebab', 'my-var')]
|
||||
[TestCase('Valid_Snake', 'my_var')]
|
||||
[TestCase('Valid_Numbered', 'var1')]
|
||||
[TestCase('Valid_Hygienic', 'var#1')]
|
||||
procedure Test_IdentifierValidation_ValidNames(const Name: string);
|
||||
|
||||
[TestCase('Invalid_StartDigit', '1var')]
|
||||
[TestCase('Invalid_Symbol', 'var$name')]
|
||||
[TestCase('Invalid_DotStart', '.var')]
|
||||
procedure Test_IdentifierValidation_InvalidNames_LogsError(const Name: string);
|
||||
|
||||
[Test]
|
||||
procedure Test_UnresolvedIdentifier_LogsError;
|
||||
|
||||
[Test]
|
||||
[IgnoreMemoryLeaks]
|
||||
procedure Test_RedefinitionInSameScope_LogsError;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
Myc.Data.Value;
|
||||
|
||||
{ TTestAstBinder }
|
||||
|
||||
procedure TTestAstBinder.Setup;
|
||||
begin
|
||||
FRootLayout := TScope.CreateRootLayout;
|
||||
end;
|
||||
|
||||
function TTestAstBinder.Bind(const Node: IAstNode; out Layout: IScopeLayout; out Log: ICompilerLog): IAstNode;
|
||||
begin
|
||||
Log := TCompilerLog.Create;
|
||||
// TAstBinder.Bind now takes Log instead of raising exceptions
|
||||
Result := TAstBinder.Bind(FRootLayout, Node, Layout, Log);
|
||||
end;
|
||||
|
||||
function TTestAstBinder.Unwrap(const Node: IAstNode): IAstNode;
|
||||
begin
|
||||
if (Node.Kind = akBlockExpression) and (Length(Node.AsBlockExpression.Expressions) = 1) then
|
||||
Result := Node.AsBlockExpression.Expressions[0]
|
||||
else
|
||||
Result := Node;
|
||||
end;
|
||||
|
||||
// ------------------------------------------------------------------------------------------------
|
||||
// Fixed Test: Initializer Visibility
|
||||
// ------------------------------------------------------------------------------------------------
|
||||
|
||||
procedure TTestAstBinder.Test_Initializer_CanSeeOuterScope_ButNotSelf;
|
||||
var
|
||||
root, bound: IAstNode;
|
||||
layout: IScopeLayout;
|
||||
block: IBlockExpressionNode;
|
||||
decl: IVariableDeclarationNode;
|
||||
initIdent: IIdentifierNode;
|
||||
log: ICompilerLog;
|
||||
begin
|
||||
// (do (def a 10) (def b a))
|
||||
root := TAst.Block([TAst.VarDecl(TAst.Identifier('a'), TAst.Constant(10)), TAst.VarDecl(TAst.Identifier('b'), TAst.Identifier('a'))]);
|
||||
|
||||
bound := Bind(root, layout, log);
|
||||
Assert.IsFalse(log.HasErrors, 'Binding should succeed without errors.');
|
||||
|
||||
block := bound.AsBlockExpression;
|
||||
|
||||
// Check definition of 'b'
|
||||
decl := block.Expressions[1].AsVariableDeclaration;
|
||||
initIdent := decl.Initializer.AsIdentifier;
|
||||
|
||||
// 'a' is Slot 0. 'b' is Slot 1.
|
||||
Assert.AreEqual<Integer>(0, initIdent.Address.SlotIndex, 'Initializer should resolve to "a" (Slot 0).');
|
||||
Assert.AreEqual<Integer>(1, decl.Target.AsIdentifier.Address.SlotIndex, 'Target "b" should be at Slot 1.');
|
||||
end;
|
||||
|
||||
// ------------------------------------------------------------------------------------------------
|
||||
// Rule Verification: No Redefinition
|
||||
// ------------------------------------------------------------------------------------------------
|
||||
|
||||
procedure TTestAstBinder.Test_RedefinitionInSameScope_LogsError;
|
||||
var
|
||||
root: IAstNode;
|
||||
layout: IScopeLayout;
|
||||
log: ICompilerLog;
|
||||
begin
|
||||
// (do (def a 1) (def a 2)) - Forbidden!
|
||||
root := TAst.Block([TAst.VarDecl(TAst.Identifier('a'), TAst.Constant(1)), TAst.VarDecl(TAst.Identifier('a'), TAst.Constant(2))]);
|
||||
|
||||
Bind(root, layout, log);
|
||||
|
||||
Assert.IsTrue(log.HasErrors, 'Binder must log error for redefinition.');
|
||||
Assert.AreEqual('Variable "a" is already defined in this scope.', log.GetEntries[0].Message);
|
||||
end;
|
||||
|
||||
// ------------------------------------------------------------------------------------------------
|
||||
// Basic Scope & Definitions
|
||||
// ------------------------------------------------------------------------------------------------
|
||||
|
||||
procedure TTestAstBinder.Test_DefineAndResolve_LocalVariable;
|
||||
var
|
||||
root, bound: IAstNode;
|
||||
layout: IScopeLayout;
|
||||
block: IBlockExpressionNode;
|
||||
ident: IIdentifierNode;
|
||||
log: ICompilerLog;
|
||||
begin
|
||||
root := TAst.Block([TAst.VarDecl(TAst.Identifier('a'), TAst.Constant(42)), TAst.Identifier('a')]);
|
||||
bound := Bind(root, layout, log);
|
||||
|
||||
Assert.IsFalse(log.HasErrors);
|
||||
|
||||
block := bound.AsBlockExpression;
|
||||
ident := block.Expressions[1].AsIdentifier;
|
||||
Assert.AreEqual<TAddressKind>(akLocalOrParent, ident.Address.Kind);
|
||||
Assert.AreEqual<Integer>(0, ident.Address.ScopeDepth);
|
||||
Assert.AreEqual<Integer>(0, ident.Address.SlotIndex);
|
||||
end;
|
||||
|
||||
procedure TTestAstBinder.Test_Shadowing_InnerScopeHidesOuter;
|
||||
var
|
||||
root, bound: IAstNode;
|
||||
layout: IScopeLayout;
|
||||
block: IBlockExpressionNode;
|
||||
innerLambda: ILambdaExpressionNode;
|
||||
innerUsage: IIdentifierNode;
|
||||
log: ICompilerLog;
|
||||
begin
|
||||
root :=
|
||||
TAst.Block([TAst.VarDecl(TAst.Identifier('x'), TAst.Constant(1)), TAst.LambdaExpr([TAst.Identifier('x')], TAst.Identifier('x'))]);
|
||||
bound := Bind(root, layout, log);
|
||||
|
||||
Assert.IsFalse(log.HasErrors);
|
||||
|
||||
block := bound.AsBlockExpression;
|
||||
innerLambda := block.Expressions[1].AsLambdaExpression;
|
||||
innerUsage := innerLambda.Body.AsIdentifier;
|
||||
Assert.AreEqual<Integer>(1, innerUsage.Address.SlotIndex); // Parameter x (Slot 1 because <self> is Slot 0)
|
||||
end;
|
||||
|
||||
procedure TTestAstBinder.Test_ScopeIsolation_SiblingScopesCannotSeeEachOther;
|
||||
var
|
||||
root: IAstNode;
|
||||
layout: IScopeLayout;
|
||||
log: ICompilerLog;
|
||||
begin
|
||||
// (do (fn [] (def a 1)) a) -> 'a' is inside lambda, not visible outside
|
||||
root := TAst.Block([TAst.LambdaExpr([], TAst.VarDecl(TAst.Identifier('a'), TAst.Constant(1))), TAst.Identifier('a')]);
|
||||
|
||||
Bind(root, layout, log);
|
||||
|
||||
Assert.IsTrue(log.HasErrors, 'Sibling scope access should fail.');
|
||||
Assert.IsTrue(log.GetEntries[0].Message.Contains('Undefined identifier'), 'Expected undefined identifier error.');
|
||||
end;
|
||||
|
||||
// ------------------------------------------------------------------------------------------------
|
||||
// Parameters
|
||||
// ------------------------------------------------------------------------------------------------
|
||||
|
||||
procedure TTestAstBinder.Test_LambdaParameters_AreBoundToSlotsStartingAtOne;
|
||||
var
|
||||
root, bound: IAstNode;
|
||||
layout: IScopeLayout;
|
||||
lambda: ILambdaExpressionNode;
|
||||
log: ICompilerLog;
|
||||
begin
|
||||
root := TAst.LambdaExpr([TAst.Identifier('p1')], TAst.Nop);
|
||||
bound := Unwrap(Bind(root, layout, log));
|
||||
|
||||
Assert.IsFalse(log.HasErrors);
|
||||
|
||||
lambda := bound.AsLambdaExpression;
|
||||
Assert.AreEqual<Integer>(1, lambda.Parameters[0].Address.SlotIndex); // Slot 0 is reserved for <self>
|
||||
end;
|
||||
|
||||
procedure TTestAstBinder.Test_MultipleParameters_AreBoundCorrectly;
|
||||
var
|
||||
root, bound: IAstNode;
|
||||
layout: IScopeLayout;
|
||||
lambda: ILambdaExpressionNode;
|
||||
log: ICompilerLog;
|
||||
begin
|
||||
root := TAst.LambdaExpr([TAst.Identifier('a'), TAst.Identifier('b')], TAst.Nop);
|
||||
bound := Unwrap(Bind(root, layout, log));
|
||||
|
||||
Assert.IsFalse(log.HasErrors);
|
||||
|
||||
lambda := bound.AsLambdaExpression;
|
||||
Assert.AreEqual<Integer>(1, lambda.Parameters[0].Address.SlotIndex);
|
||||
Assert.AreEqual<Integer>(2, lambda.Parameters[1].Address.SlotIndex);
|
||||
end;
|
||||
|
||||
// ------------------------------------------------------------------------------------------------
|
||||
// Upvalues / Closures
|
||||
// ------------------------------------------------------------------------------------------------
|
||||
|
||||
procedure TTestAstBinder.Test_Capture_ImmediateParent;
|
||||
var
|
||||
root, bound: IAstNode;
|
||||
layout: IScopeLayout;
|
||||
block: IBlockExpressionNode;
|
||||
lambda: ILambdaExpressionNode;
|
||||
bodyIdent: IIdentifierNode;
|
||||
log: ICompilerLog;
|
||||
begin
|
||||
root := TAst.Block([TAst.VarDecl(TAst.Identifier('x'), TAst.Constant(99)), TAst.LambdaExpr([], TAst.Identifier('x'))]);
|
||||
bound := Bind(root, layout, log);
|
||||
|
||||
Assert.IsFalse(log.HasErrors);
|
||||
|
||||
block := bound.AsBlockExpression;
|
||||
lambda := block.Expressions[1].AsLambdaExpression;
|
||||
bodyIdent := lambda.Body.AsIdentifier;
|
||||
|
||||
// Inside the lambda, 'x' is accessed via an Upvalue
|
||||
Assert.AreEqual<TAddressKind>(akUpvalue, bodyIdent.Address.Kind);
|
||||
Assert.AreEqual<Integer>(0, bodyIdent.Address.SlotIndex); // First captured value
|
||||
end;
|
||||
|
||||
procedure TTestAstBinder.Test_Capture_GrandParent_PropagatesThroughIntermediateScope;
|
||||
var
|
||||
root, bound: IAstNode;
|
||||
layout: IScopeLayout;
|
||||
outerBlock: IBlockExpressionNode;
|
||||
midLambda, innerLambda: ILambdaExpressionNode;
|
||||
log: ICompilerLog;
|
||||
begin
|
||||
root :=
|
||||
TAst.Block(
|
||||
[TAst.VarDecl(TAst.Identifier('top'), TAst.Constant(100)), TAst.LambdaExpr([], TAst.LambdaExpr([], TAst.Identifier('top')))]
|
||||
);
|
||||
bound := Bind(root, layout, log);
|
||||
|
||||
Assert.IsFalse(log.HasErrors);
|
||||
|
||||
outerBlock := bound.AsBlockExpression;
|
||||
midLambda := outerBlock.Expressions[1].AsLambdaExpression;
|
||||
innerLambda := midLambda.Body.AsLambdaExpression;
|
||||
|
||||
// Inner lambda accesses 'top' via upvalue
|
||||
Assert.AreEqual<TAddressKind>(akUpvalue, innerLambda.Body.AsIdentifier.Address.Kind);
|
||||
end;
|
||||
|
||||
procedure TTestAstBinder.Test_Self_IsImplicitlyDefinedInLambda;
|
||||
var
|
||||
root, bound: IAstNode;
|
||||
layout: IScopeLayout;
|
||||
lambda: ILambdaExpressionNode;
|
||||
log: ICompilerLog;
|
||||
begin
|
||||
root := TAst.LambdaExpr([], TAst.Identifier('<self>'));
|
||||
bound := Unwrap(Bind(root, layout, log));
|
||||
|
||||
Assert.IsFalse(log.HasErrors);
|
||||
|
||||
lambda := bound.AsLambdaExpression;
|
||||
// <self> is always at Slot 0 (Local)
|
||||
Assert.AreEqual<TAddressKind>(akLocalOrParent, lambda.Body.AsIdentifier.Address.Kind);
|
||||
Assert.AreEqual<Integer>(0, lambda.Body.AsIdentifier.Address.SlotIndex);
|
||||
end;
|
||||
|
||||
// ------------------------------------------------------------------------------------------------
|
||||
// Validation Tests
|
||||
// ------------------------------------------------------------------------------------------------
|
||||
|
||||
procedure TTestAstBinder.Test_IdentifierValidation_ValidNames(const Name: string);
|
||||
var
|
||||
root: IAstNode;
|
||||
layout: IScopeLayout;
|
||||
log: ICompilerLog;
|
||||
begin
|
||||
root := TAst.VarDecl(TAst.Identifier(Name), nil);
|
||||
Bind(root, layout, log);
|
||||
Assert.IsFalse(log.HasErrors, 'Valid name should not produce errors.');
|
||||
end;
|
||||
|
||||
procedure TTestAstBinder.Test_IdentifierValidation_InvalidNames_LogsError(const Name: string);
|
||||
var
|
||||
root: IAstNode;
|
||||
layout: IScopeLayout;
|
||||
log: ICompilerLog;
|
||||
begin
|
||||
root := TAst.VarDecl(TAst.Identifier(Name), nil);
|
||||
Bind(root, layout, log);
|
||||
|
||||
Assert.IsTrue(log.HasErrors, 'Invalid name should produce error.');
|
||||
Assert.IsTrue(log.GetEntries[0].Message.Contains('Invalid identifier name'));
|
||||
end;
|
||||
|
||||
procedure TTestAstBinder.Test_UnresolvedIdentifier_LogsError;
|
||||
var
|
||||
root: IAstNode;
|
||||
layout: IScopeLayout;
|
||||
log: ICompilerLog;
|
||||
begin
|
||||
root := TAst.Identifier('z');
|
||||
Bind(root, layout, log);
|
||||
|
||||
Assert.IsTrue(log.HasErrors, 'Unresolved identifier should produce error.');
|
||||
Assert.IsTrue(log.GetEntries[0].Message.Contains('Undefined identifier'));
|
||||
end;
|
||||
|
||||
end.
|
||||
Reference in New Issue
Block a user