Brummel/MycLib
1
0
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects 1 Releases Wiki Activity

Ast editor custom draw

Browse Source
This commit is contained in:
Michael Schimmel
2025-12-06 17:32:04 +01:00
parent 9ed563bcc1
commit e40f56eaeb
10 changed files with 1629 additions and 1439 deletions
Download Patch File Download Diff File Expand all files Collapse all files
Src/AST/Myc.Fmx.AstEditor.Node.pas
+174 -260
View File
@@ -12,13 +12,11 @@ uses
System.Generics.Defaults,
System.Generics.Collections,
FMX.Types,
FMX.Controls,
FMX.Objects,
FMX.Graphics,
FMX.StdCtrls,
FMX.TextLayout,
Myc.Ast.Nodes,
Myc.Fmx.AstEditor.Workspace,
Myc.Fmx.AstEditor.Layout;
Myc.Fmx.AstEditor.Render,
Myc.Fmx.AstEditor.Workspace;
const
cNodePadding = 10;
@@ -26,7 +24,7 @@ const
cTitleBottomPadding = 4;
cMinNodeWidth = 10;
cMinNodeHeight = 10;
cDragGutterWidth = 20; // Width of the trigger zone for dragging
cDragGutterWidth = 20;
type
TAstViewNode = class;
@@ -40,26 +38,26 @@ type
IReorderable = interface
['{9FA7C504-D327-4E00-A5FE-DD2876886212}']
function CanDrag(Child: TControl): Boolean;
function CanDrag(Child: TVisualNode): Boolean;
procedure MoveChild(SourceIndex, TargetIndex: Integer);
end;
IAstVisualizer = interface
{$region 'private'}
function GetExprDepth: Integer;
function GetParentControl: TControl;
function GetParentNode: TVisualNode;
function GetWorkspace: TWorkspace;
{$endregion}
function Clone(ParentControl: TControl; ExprDepth: Integer): IAstVisualizer;
function Clone(ParentNode: TVisualNode; ExprDepth: Integer): IAstVisualizer;
function CallAccept(const Node: IAstNode): TAstViewNode;
property ExprDepth: Integer read GetExprDepth;
property ParentControl: TControl read GetParentControl;
property ParentNode: TVisualNode read GetParentNode;
property Workspace: TWorkspace read GetWorkspace;
end;
TAstViewNode = class(TAutoFitControl)
TAstViewNode = class(TAutoFitLayout)
private
FBackgroundColor: TAlphaColor;
FBorderColor: TAlphaColor;
@@ -73,6 +71,7 @@ type
FTypeInfoText: string;
FIsFocused: Boolean;
FIsHovered: Boolean;
procedure SetBackgroundColor(const Value: TAlphaColor);
procedure SetBorderColor(const Value: TAlphaColor);
@@ -83,28 +82,27 @@ type
procedure SetErrorMessage(const Value: string);
procedure SetTypeInfoText(const Value: string);
procedure UpdateVisualState;
procedure SetIsFocused(const Value: Boolean);
procedure InvalidateVisuals;
protected
procedure Paint; override;
procedure DoPaint(Canvas: TCanvas; const Offset: TPointF); override;
procedure SetupNode;
procedure DoMouseEnter; override;
procedure DoMouseLeave; 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;
public
constructor Create(const AVisualizer: IAstVisualizer; const AHandler: IAstViewNodeHandler); 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): TAstViewNode;
procedure MouseEnter; override;
procedure MouseLeave; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single); override;
procedure MouseMove(Shift: TShiftState; X, Y: Single); override;
function AddLabel(Parent: TVisualNode; const Txt: String): TTextNode;
function AddContainer(Parent: TVisualNode; Orientation: TLayoutOrientation; Alignment: TLayoutAlignment): TAutoFitLayout;
function AddExpr(Parent: TVisualNode; const Title: String; const Node: IAstNode): TAstViewNode;
function CreateAst: IAstNode;
@@ -116,42 +114,11 @@ type
property TypeInfoText: string read FTypeInfoText write SetTypeInfoText;
property IsFocused: Boolean read FIsFocused write SetIsFocused;
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;
TBaseNodeHandler<T: IAstNode> = class(TInterfacedObject, IAstViewNodeHandler)
@@ -173,9 +140,10 @@ uses
constructor TAstViewNode.Create(const AVisualizer: IAstVisualizer; const AHandler: IAstViewNodeHandler);
begin
inherited Create(AVisualizer.Workspace);
inherited Create(AVisualizer.Workspace as IVisualHost);
Parent := AVisualizer.ParentControl;
if Assigned(AVisualizer.ParentNode) then
AVisualizer.ParentNode.AddChild(Self);
FVisualizer := AVisualizer.Clone(Self, AVisualizer.ExprDepth);
FHandler := AHandler;
@@ -187,25 +155,18 @@ begin
FFrameless := False;
FIsFocused := False;
FIsHovered := False;
Width := cMinNodeWidth;
Height := cMinNodeHeight;
Size := TSizeF.Create(cMinNodeWidth, cMinNodeHeight);
HitTest := True;
ClipChildren := True;
HitTestEnabled := 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;
Margins := TMarginRect.Create(4, 4, 4, 4);
Padding := TMarginRect.Create(3, 3, 3, 3);
var cn: Cardinal := $ea - (7 * FVisualizer.ExprDepth);
var c: Cardinal := $ff000000 or (cn shl 16) or (cn shl 8) or cn;
BackgroundColor := c;
FBackgroundColor := c;
end;
destructor TAstViewNode.Destroy;
@@ -214,103 +175,18 @@ begin
inherited;
end;
procedure TAstViewNode.DoMouseEnter;
begin
inherited;
Repaint;
end;
procedure TAstViewNode.DoMouseLeave;
begin
inherited;
Repaint;
end;
procedure TAstViewNode.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
const
cHeaderHeight = 30; // Defined height for header drag area
begin
// Check for Drag Start.
// Condition: Left Click AND we are part of a container (list)
if (Button = TMouseButton.mbLeft) and (Parent is TAutoFitControl) then
begin
// Hit-Test: Either Gutter (Left) OR Header area (Top)
if (X < cDragGutterWidth) or (Y < cHeaderHeight) then
begin
if Assigned(FVisualizer.Workspace) then
begin
FVisualizer.Workspace.BeginDragNode(Self);
Exit;
end;
end;
end;
inherited;
end;
procedure TAstViewNode.MouseMove(Shift: TShiftState; X, Y: Single);
const
cHeaderHeight = 30;
begin
// Cursor Logic (Hover Feedback)
if (Parent is TAutoFitControl) and ((X < cDragGutterWidth) or (Y < cHeaderHeight)) then
Cursor := crSizeAll
else
Cursor := crDefault;
inherited;
end;
procedure TAstViewNode.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
begin
inherited;
end;
function TAstViewNode.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 TAstViewNode.AddExpr(Parent: TControl; const Title: String; const Node: IAstNode): TAstViewNode;
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 TAstViewNode.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 TAstViewNode.AfterConstruction;
begin
inherited;
SetupNode;
end;
procedure TAstViewNode.SetupNode;
begin
if Assigned(FHandler) then
FHandler.BuildUI(Self);
end;
function TAstViewNode.CreateAst: IAstNode;
begin
if Assigned(FHandler) then
@@ -327,154 +203,142 @@ begin
Result := nil;
end;
procedure TAstViewNode.SetErrorMessage(const Value: string);
function TAstViewNode.AddContainer(Parent: TVisualNode; Orientation: TLayoutOrientation; Alignment: TLayoutAlignment): TAutoFitLayout;
begin
if FErrorMessage <> Value then
begin
FErrorMessage := Value;
UpdateVisualState;
Repaint;
end;
Result := TAutoFitLayout.Create(Host);
Parent.AddChild(Result);
Result.Orientation := Orientation;
Result.Alignment := Alignment;
Result.HitTestEnabled := False;
end;
procedure TAstViewNode.SetTypeInfoText(const Value: string);
function TAstViewNode.AddExpr(Parent: TVisualNode; const Title: String; const Node: IAstNode): TAstViewNode;
begin
if FTypeInfoText <> Value then
begin
FTypeInfoText := Value;
UpdateVisualState;
end;
var cont := AddContainer(Parent, loHorizontal, laCenter);
var lbl := AddLabel(cont, Title);
lbl.FontSettings.Font.Style := [TFontStyle.fsBold];
Result := FVisualizer.Clone(cont, FVisualizer.ExprDepth + 1).CallAccept(Node);
end;
procedure TAstViewNode.SetIsFocused(const Value: Boolean);
function TAstViewNode.AddLabel(Parent: TVisualNode; const Txt: String): TTextNode;
begin
if FIsFocused <> Value then
begin
FIsFocused := Value;
Repaint;
end;
Result := TTextNode.Create(Host);
Parent.AddChild(Result);
Result.Margins := TMarginRect.Create(cNodePadding, cTitleTopPadding, cNodePadding, cTitleBottomPadding);
Result.Padding := TMarginRect.Create(0, 0, 0, 0);
Result.Text := Txt;
end;
procedure TAstViewNode.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 TAstViewNode.Paint;
procedure TAstViewNode.DoPaint(Canvas: TCanvas; const Offset: TPointF);
var
rect: TRectF;
effBorderColor: TAlphaColor;
effBorderWidth: Single;
effDash: TStrokeDash;
isHovering: Boolean;
shouldIgnoreHover: Boolean;
Rect: TRectF;
EffBorderColor: TAlphaColor;
EffBorderWidth: Single;
EffDash: TStrokeDash;
ShouldIgnoreHover: Boolean;
begin
inherited;
Rect := TRectF.Create(Offset, Size.Width, Size.Height);
shouldIgnoreHover := False;
ShouldIgnoreHover := False;
if Assigned(Node) then
begin
case Node.Kind of
akBlockExpression, akParameterList, akArgumentList, akExpressionList, akRecordFieldList: shouldIgnoreHover := True;
akBlockExpression, akParameterList, akArgumentList, akExpressionList, akRecordFieldList: ShouldIgnoreHover := True;
end;
end;
isHovering := IsMouseOver and (not shouldIgnoreHover);
// 1. Determine Base Style
if FFrameless then
begin
effBorderColor := FBorderColor;
effBorderWidth := FBorderWidth;
effDash := TStrokeDash.Dot;
EffBorderColor := FBorderColor;
EffBorderWidth := FBorderWidth;
EffDash := TStrokeDash.Dot;
end
else
begin
effBorderColor := FBorderColor;
effBorderWidth := FBorderWidth;
effDash := TStrokeDash.Solid;
EffBorderColor := FBorderColor;
EffBorderWidth := FBorderWidth;
EffDash := TStrokeDash.Solid;
end;
// 2. Hover Overlay
if isHovering then
if FIsHovered and (not ShouldIgnoreHover) then
begin
effBorderColor := TAlphaColors.White;
effBorderWidth := Max(2.0, FBorderWidth + 1.0);
effDash := TStrokeDash.Solid;
EffBorderColor := TAlphaColors.White;
EffBorderWidth := Max(2.0, FBorderWidth + 1.0);
EffDash := TStrokeDash.Solid;
end;
// 3. Error Overlay (High Priority for Color)
if FErrorMessage <> '' then
begin
effBorderColor := TAlphaColors.Red;
effBorderWidth := 2.0;
effDash := TStrokeDash.Solid;
EffBorderColor := TAlphaColors.Red;
EffBorderWidth := 2.0;
EffDash := TStrokeDash.Solid;
end;
// 4. Focus Overlay (Highest Priority for Visibility/Color)
// Note: If Error is present, Focus will override color to Blue to indicate "Active Cursor".
// Error text is available in Hint.
if FIsFocused then
begin
effBorderColor := TAlphaColors.Dodgerblue;
effBorderWidth := 2.0;
effDash := TStrokeDash.Solid;
EffBorderColor := TAlphaColors.Dodgerblue;
EffBorderWidth := 2.0;
EffDash := TStrokeDash.Solid;
end;
Canvas.Fill.Kind := TBrushKind.Solid;
Canvas.Fill.Color := FBackgroundColor;
if FFrameless and (FErrorMessage = '') and (not isHovering) and (not FIsFocused) then
if FFrameless and (FErrorMessage = '') and (not FIsHovered) and (not FIsFocused) then
begin
Canvas.FillRect(TRectF.Create(0, 0, Width, Height), 0, 0, [], 1.0);
Canvas.FillRect(Rect, 0, 0, AllCorners, 1.0);
if FBorderWidth > 0 then
begin
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);
Canvas.Stroke.Color := EffBorderColor;
Canvas.Stroke.Thickness := EffBorderWidth;
Canvas.Stroke.Dash := EffDash;
Canvas.DrawRect(Rect, 0, 0, AllCorners, 1.0);
end;
end
else
begin
rect := TRectF.Create(0, 0, Width, Height);
if (effBorderWidth > 0) then
rect.Inflate(-effBorderWidth / 2, -effBorderWidth / 2);
var DrawRect := Rect;
if EffBorderWidth > 0 then
DrawRect.Inflate(-EffBorderWidth / 2, -EffBorderWidth / 2);
Canvas.FillRect(rect, FBorderRadius, FBorderRadius, AllCorners, 1.0, TCornerType.Round);
Canvas.FillRect(DrawRect, FBorderRadius, FBorderRadius, AllCorners, 1.0, TCornerType.Round);
if (effBorderWidth > 0) and (effBorderColor <> TAlphaColors.Null) then
if (EffBorderWidth > 0) and (EffBorderColor <> TAlphaColors.Null) then
begin
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);
Canvas.Stroke.Color := EffBorderColor;
Canvas.Stroke.Thickness := EffBorderWidth;
Canvas.Stroke.Dash := EffDash;
Canvas.DrawRect(DrawRect, FBorderRadius, FBorderRadius, AllCorners, 1.0, TCornerType.Round);
end;
end;
if isHovering and (Parent is TAutoFitControl) then
if FIsHovered and (Parent is TAutoFitLayout) then
begin
Canvas.Fill.Color := TAlphaColors.DimGray;
Canvas.FillEllipse(TRectF.Create(4, 6, 8, 10), 1.0);
Canvas.FillEllipse(TRectF.Create(4, 12, 8, 16), 1.0);
Canvas.FillEllipse(TRectF.Create(4, 18, 8, 22), 1.0);
Canvas.FillEllipse(TRectF.Create(Offset.X + 4, Offset.Y + 6, Offset.X + 12, Offset.Y + 14), 1.0);
Canvas.FillEllipse(TRectF.Create(Offset.X + 4, Offset.Y + 16, Offset.X + 12, Offset.Y + 24), 1.0);
end;
end;
procedure TAstViewNode.InvalidateVisuals;
begin
if Assigned(Host) then
Host.InvalidateRect(AbsoluteRect);
end;
procedure TAstViewNode.SetBackgroundColor(const Value: TAlphaColor);
begin
if FBackgroundColor <> Value then
begin
FBackgroundColor := Value;
InvalidateVisuals;
end;
end;
@@ -483,7 +347,7 @@ begin
if FBorderColor <> Value then
begin
FBorderColor := Value;
Repaint;
InvalidateVisuals;
end;
end;
@@ -492,7 +356,7 @@ begin
if FBorderRadius <> Value then
begin
FBorderRadius := Value;
Repaint;
InvalidateVisuals;
end;
end;
@@ -501,7 +365,17 @@ begin
if FBorderWidth <> Value then
begin
FBorderWidth := Value;
Repaint;
RequestLayout;
InvalidateVisuals;
end;
end;
procedure TAstViewNode.SetErrorMessage(const Value: string);
begin
if FErrorMessage <> Value then
begin
FErrorMessage := Value;
InvalidateVisuals;
end;
end;
@@ -510,20 +384,60 @@ begin
if FFrameless <> Value then
begin
FFrameless := Value;
Repaint;
InvalidateVisuals;
end;
end;
procedure TAstViewNode.SetBackgroundColor(const Value: TAlphaColor);
procedure TAstViewNode.SetIsFocused(const Value: Boolean);
begin
FBackgroundColor := Value;
Repaint;
if FIsFocused <> Value then
begin
FIsFocused := Value;
InvalidateVisuals;
end;
end;
procedure TAstViewNode.SetupNode;
procedure TAstViewNode.SetTypeInfoText(const Value: string);
begin
if Assigned(FHandler) then
FHandler.BuildUI(Self);
if FTypeInfoText <> Value then
begin
FTypeInfoText := Value;
end;
end;
procedure TAstViewNode.MouseEnter;
begin
FIsHovered := True;
InvalidateVisuals;
end;
procedure TAstViewNode.MouseLeave;
begin
FIsHovered := False;
InvalidateVisuals;
end;
procedure TAstViewNode.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Single);
const
cHeaderHeight = 30;
begin
if (Button = TMouseButton.mbLeft) and (Parent is TAutoFitLayout) then
begin
if (X < cDragGutterWidth) or (Y < cHeaderHeight) then
begin
if Assigned(FVisualizer.Workspace) then
begin
FVisualizer.Workspace.BeginDragNode(Self);
Exit;
end;
end;
end;
inherited;
end;
procedure TAstViewNode.MouseMove(Shift: TShiftState; X, Y: Single);
begin
inherited;
end;
{ TBaseNodeHandler<T> }