Skip to content

Commit c5d8ad8

Browse files
TorwentTorwent
committed
feat: add full RGB background colors to the output
1 parent 8140cac commit c5d8ad8

7 files changed

Lines changed: 121 additions & 77 deletions

File tree

‎Source/ide/simba.form_output.lfm‎

Lines changed: 8 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,19 +1,18 @@
11
object SimbaOutputForm: TSimbaOutputForm
22
Left = 4227
3-
Height = 140
3+
Height = 112
44
Top = 24
5-
Width = 676
5+
Width = 541
66
Caption = 'Output'
7-
DesignTimePPI = 120
7+
ShowInTaskBar = stAlways
8+
LCLVersion = '4.4.0.0'
89
OnMouseDown = FormMouseDown
910
OnMouseLeave = FormMouseLeave
1011
OnMouseMove = FormMouseMove
11-
ShowInTaskBar = stAlways
12-
LCLVersion = '3.4.0.0'
1312
object ContextMenu: TPopupMenu
1413
OnMeasureItem = ContextMenuMeasureItem
15-
Left = 40
16-
Top = 56
14+
Left = 32
15+
Top = 45
1716
object MenuItemCopyLine: TMenuItem
1817
Caption = 'Copy Line'
1918
OnClick = MenuItemCopyLineClick
@@ -44,7 +43,7 @@ object SimbaOutputForm: TSimbaOutputForm
4443
object FlushTimer: TTimer
4544
Interval = 500
4645
OnTimer = DoFlushTimerExecute
47-
Left = 128
48-
Top = 56
46+
Left = 102
47+
Top = 45
4948
end
5049
end

‎Source/ide/simba.form_output.pas‎

Lines changed: 42 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -135,6 +135,13 @@ TSimbaOutputTab = class(TSimbaTab)
135135
property OutputBox: TSimbaOutputBox read FOutputBox;
136136
end;
137137

138+
type
139+
PLineFlagsData = ^TLineFlagsData;
140+
TLineFlagsData = record
141+
Flags: EDebugLnFlags;
142+
Color: TColor;
143+
end;
144+
138145
procedure TSimbaOutputTab.DoTabScriptStateChange(Sender: TObject);
139146
begin
140147
if (Sender is TSimbaScriptTab) and (TSimbaScriptTab(Sender).OutputBox = FOutputBox) then
@@ -240,19 +247,21 @@ procedure TSimbaOutputBox.DoOpenLink(Data: PtrInt);
240247

241248
procedure TSimbaOutputBox.DoSpecialLineMarkup(Sender: TObject; Line: Integer; var Special: Boolean; AMarkup: TSynSelectedColor);
242249
var
243-
Flags: EDebugLnFlags;
250+
lineData: PLineFlagsData;
244251
begin
245-
Flags := EDebugLnFlags(Integer(PtrUInt(Lines.Objects[Line - 1])));
252+
lineData := PLineFlagsData(Lines.Objects[Line - 1]);
246253

247-
if (([EDebugLn.YELLOW, EDebugLn.RED, EDebugLn.GREEN] * Flags) <> []) then
254+
if lineData = nil then
248255
begin
249-
if (EDebugLn.YELLOW in Flags) then AMarkup.Background := $00BFFF else
250-
if (EDebugLn.RED in Flags) then AMarkup.Background := $0000A5 else
251-
if (EDebugLn.GREEN in Flags) then AMarkup.Background := $228B22;
256+
Special := False;
257+
Exit;
258+
end;
252259

260+
if EDebugLn.BACKGROUND_COLOR in lineData.Flags then
261+
begin
262+
AMarkup.Background := lineData.Color;
253263
AMarkup.BackAlpha := 115;
254264
AMarkup.Foreground := clNone;
255-
256265
Special := True;
257266
end else
258267
Special := False;
@@ -304,16 +313,22 @@ constructor TSimbaOutputBox.Create(AOwner: TComponent);
304313
end;
305314

306315
destructor TSimbaOutputBox.Destroy;
316+
var
317+
i: Integer;
307318
begin
308-
if (FLock <> nil) then
309-
FreeAndNil(FLock);
310319
if (FBuffer <> nil) then
320+
begin
321+
for i := 0 to FBuffer.Count - 1 do
322+
Dispose(PLineFlagsData(FBuffer.Objects[i]))
311323
FreeAndNil(FBuffer);
324+
end;
325+
if (FLock <> nil) then
326+
FreeAndNil(FLock);
312327

313328
inherited Destroy();
314329
end;
315330

316-
procedure TSimbaOutputBox.GetWordBoundsAtRowCol(const XY: TPoint; out StartX, EndX: integer);
331+
procedure TSimbaOutputBox.GetWordBoundsAtRowCol(const XY: TPoint; out StartX, EndX: Integer);
317332

318333
// Line 3 in function "cpuuu" in file "Untitled"
319334
function FindStackTrace(Line: String; var StartPos, EndPos: Integer): Boolean;
@@ -386,7 +401,7 @@ function TSimbaOutputBox.Add(const S: String): String;
386401
Arr: TStringArray;
387402
I: Integer;
388403
Line: String;
389-
Flags: EDebugLnFlags;
404+
lineData: PLineData;
390405
begin
391406
Arr := S.Split(LineEnding, False);
392407
if (Length(Arr) = 0) then
@@ -402,9 +417,9 @@ function TSimbaOutputBox.Add(const S: String): String;
402417
for I := 0 to High(Arr) do
403418
begin
404419
Line := Arr[I];
405-
Flags := FlagsFromString(Line);
406-
407-
FBuffer.AddObject(Line, TObject(PtrUInt(Integer(Flags))));
420+
New(lineData);
421+
lineData^.Flags := FlagsFromString(Line, lineData^.Color);
422+
FBuffer.AddObject(Line, TObject(data));
408423
end;
409424
end else
410425
begin
@@ -413,9 +428,9 @@ function TSimbaOutputBox.Add(const S: String): String;
413428
for I := 0 to High(Arr) - 1 do
414429
begin
415430
Line := Arr[I];
416-
Flags := FlagsFromString(Line);
417-
418-
FBuffer.AddObject(Line, TObject(PtrUInt(Integer(Flags))));
431+
New(lineData);
432+
lineData^.Flags := FlagsFromString(Line, lineData^.Color);
433+
FBuffer.AddObject(Line, TObject(data));
419434
end;
420435
end;
421436

@@ -439,7 +454,7 @@ procedure TSimbaOutputBox.Flush;
439454
var
440455
I, StartIndex: Integer;
441456
NeedFocus, NeedScroll: Boolean;
442-
Flags: EDebugLnFlags;
457+
lineData: PLineFlagsData;
443458
begin
444459
FLock.Enter();
445460

@@ -451,10 +466,10 @@ procedure TSimbaOutputBox.Flush;
451466
StartIndex := 0;
452467
for I := 0 to FBuffer.Count - 1 do
453468
begin
454-
Flags := EDebugLnFlags(Integer(PtrUInt(FBuffer.Objects[I])));
455-
if (EDebugLn.CLEAR in Flags) then
469+
lineData := PLineFlagsData(FBuffer.Objects[I]);
470+
if (EDebugLn.CLEAR in lineData^.Flags) then
456471
StartIndex := I+1;
457-
if (EDebugLn.FOCUS in Flags) then
472+
if (EDebugLn.FOCUS in lineData^.Flags) then
458473
NeedFocus := True;
459474
end;
460475

@@ -465,7 +480,10 @@ procedure TSimbaOutputBox.Flush;
465480
// auto scroll if already scrolled to bottom.
466481
NeedScroll := (Lines.Count < LinesInWindow) or ((Lines.Count + 1) = (TopLine + LinesInWindow));
467482
for I := StartIndex to FBuffer.Count - 1 do
468-
Lines.AddObject(FBuffer[I], FBuffer.Objects[I]);
483+
begin
484+
lineData := PLineFlagsData(FBuffer.Objects[I]);
485+
Lines.AddObject(FBuffer[I], TObject(lineData));
486+
end;
469487

470488
if NeedFocus or NeedScroll then
471489
begin
@@ -477,6 +495,8 @@ procedure TSimbaOutputBox.Flush;
477495
EndUpdate();
478496
Invalidate();
479497

498+
for I := 0 to FBuffer.Count - 1 do
499+
Dispose(PLineFlagsData(FBuffer.Objects[I]));
480500
FBuffer.Clear();
481501
end;
482502
finally

‎Source/script/simba.script.pas‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -125,7 +125,7 @@ function TSimbaScript.DoCompilerMacro(Sender: TLapeCompiler; Name, Argument: lpS
125125

126126
procedure TSimbaScript.DoCompilerHint(Sender: TLapeCompilerBase; Hint: lpString);
127127
begin
128-
DebugLn([EDebugLn.YELLOW], Hint);
128+
DebugLn([EDebugLn.BACKGROUND_COLOR], GetLineColor(EDebugLnColor.YELLOW), Hint);
129129
end;
130130

131131
procedure TSimbaScript.DoCompilerFindFile(Sender: TLapeCompiler; var FileName: lpString);

‎Source/script/simba.script_runner.pas‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -56,7 +56,7 @@ procedure TSimbaScriptRunner.DoDebugLn(Flags: EDebugLnFlags; Text: String);
5656

5757
procedure TSimbaScriptRunner.DoCompilerHint(Sender: TLapeCompilerBase; Hint: lpString);
5858
begin
59-
DoDebugLn([EDebugLn.YELLOW], Hint);
59+
DebugLn([EDebugLn.BACKGROUND_COLOR], GetLineColor(EDebugLnColor.YELLOW), Hint);
6060
end;
6161

6262
procedure TSimbaScriptRunner.DoApplicationTerminate(Sender: TObject);
@@ -83,15 +83,15 @@ procedure TSimbaScriptRunner.DoError(E: Exception);
8383
begin
8484
ExitCode := 1;
8585

86-
DoDebugLn([EDebugLn.RED, EDebugLn.FOCUS], E.Message);
86+
DoDebugLn([EDebugLn.BACKGROUND_COLOR, EDebugLn.FOCUS], GetLineColor(EDebugLnColor.RED), E.Message);
8787

8888
if (E is lpException) then
8989
with lpException(E) do
9090
begin
9191
for Line in StackTrace.Split(LineEnding) do
92-
DoDebugLn([EDebugLn.RED, EDebugLn.FOCUS], Line);
92+
DoDebugLn([EDebugLn.BACKGROUND_COLOR, EDebugLn.FOCUS], GetLineColor(EDebugLnColor.RED), Line);
9393
for Line in Hint.Split(LineEnding) do
94-
DoDebugLn([EDebugLn.YELLOW, EDebugLn.FOCUS], Line);
94+
DoDebugLn([EDebugLn.BACKGROUND_COLOR, EDebugLn.FOCUS], GetLineColor(EDebugLnColor.YELLOW), Line);
9595

9696
if (FScript.SimbaCommunication <> nil) then
9797
FScript.SimbaCommunication.ScriptError(Message, DocPos.Line, DocPos.Col, DocPos.FileName);

‎Source/simba.base.pas‎

Lines changed: 60 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -279,7 +279,8 @@ TBox = record
279279
{$PUSH}
280280
{$SCOPEDENUMS ON}
281281
type
282-
EDebugLn = (CLEAR, YELLOW, RED, GREEN, FOCUS);
282+
EDebugLn = (CLEAR, FOCUS, BACKGROUND_COLOR);
283+
EDebugLnColor = (YELLOW, RED, GREEN);
283284
EDebugLnFlags = set of EDebugLn;
284285
{$POP}
285286

@@ -291,10 +292,14 @@ procedure Debug(const Msg: String; Args: array of const); overload;
291292
procedure DebugLn(const Msg: String); overload;
292293
procedure DebugLn(const Msg: String; Args: array of const); overload;
293294
procedure DebugLn(const Flags: EDebugLnFlags; const Msg: String); overload;
295+
procedure DebugLn(const Flags: EDebugLnFlags; bgColor: TColor; const Msg: String); overload;
294296
procedure DebugLn(const Flags: EDebugLnFlags; const Msg: String; Args: array of const); overload;
297+
procedure DebugLn(const Flags: EDebugLnFlags; bgColor: TColor; const Msg: String; Args: array of const); overload;
295298

296-
function FlagsToString(const Flags: EDebugLnFlags): String;
297-
function FlagsFromString(var Str: String): EDebugLnFlags;
299+
function GetLineColor(const color: EDebugLnColor): TColor;
300+
301+
function FlagsToString(const flags: EDebugLnFlags; const bgColor: TColor): String;
302+
function FlagsFromString(var Str: String; out bgColor: Int32): EDebugLnFlags;
298303

299304
function InRange(const AValue, AMin, AMax: Integer): Boolean; inline; overload;
300305
function InRange(const AValue, AMin, AMax: Int64): Boolean; inline; overload;
@@ -412,12 +417,22 @@ procedure DebugLn(const Msg: String; Args: array of const);
412417

413418
procedure DebugLn(const Flags: EDebugLnFlags; const Msg: String);
414419
begin
415-
DebugLn(FlagsToString(Flags) + Msg);
420+
DebugLn(FlagsToString(Flags, $0) + Msg);
421+
end;
422+
423+
procedure DebugLn(const Flags: EDebugLnFlags; bgColor: TColor; const Msg: String);
424+
begin
425+
DebugLn(FlagsToString(Flags, bgColor) + Msg);
416426
end;
417427

418428
procedure DebugLn(const Flags: EDebugLnFlags; const Msg: String; Args: array of const);
419429
begin
420-
DebugLn(FlagsToString(Flags) + Format(Msg, Args));
430+
DebugLn(FlagsToString(Flags, $0) + Format(Msg, Args));
431+
end;
432+
433+
procedure DebugLn(const Flags: EDebugLnFlags; bgColor: TColor; const Msg: String; Args: array of const);
434+
begin
435+
DebugLn(FlagsToString(Flags, bgColor) + Format(Msg, Args));
421436
end;
422437

423438
procedure SimbaException(Message: String; Args: array of const);
@@ -430,48 +445,58 @@ procedure SimbaException(Message: String);
430445
raise ESimbaException.Create(Message);
431446
end;
432447

433-
const
434-
DebugLnFlagsHeader = String(#0#0);
435-
DebugLnFlagsHeaderLength = Length(DebugLnFlagsHeader) + 6;
436448

437-
function FlagsToString(const Flags: EDebugLnFlags): String; inline;
449+
function GetLineColor(const color: EDebugLnColor): TColor; inline;
450+
const
451+
DEBUG_LINE_COLORS: array [EDebugLnColor] of TColor = [
452+
$00BFFF, $0000A5, $228B22
453+
];
438454
begin
439-
Result := DebugLnFlagsHeader + IntToHex(Integer(Flags), 6);
455+
Result := DEBUG_LINE_COLORS[color];
440456
end;
441457

442-
function FlagsFromString(var Str: String): EDebugLnFlags;
458+
const
459+
DebugLnFlagsHeader = String(#0#0);
460+
DebugLnFlagsHeaderLength = Length(DebugLnFlagsHeader) + 6;
443461

444-
function HexToInt(P: PChar): Integer; inline;
445-
var
446-
N, I: Integer;
447-
Val: Char;
462+
function FlagsToString(const flags: EDebugLnFlags; const bgColor: TColor): String; inline;
463+
begin
464+
Result := DebugLnFlagsHeader;
465+
Result := Result + Chr(Byte(flags));
466+
if (EDebugLn.BACKGROUND_COLOR in flags) then
448467
begin
449-
Result := 0;
450-
451-
for I := 1 to 6 do
452-
begin
453-
Val := P^;
454-
case Val of
455-
'0'..'9': N := Ord(Val) - (Ord('0'));
456-
'a'..'f': N := Ord(Val) - (Ord('a') - 10);
457-
'A'..'F': N := Ord(Val) - (Ord('A') - 10);
458-
else
459-
Exit(0);
460-
end;
461-
Inc(P);
462-
463-
Result := Result*16+N;
464-
end;
468+
Result := Result + Chr((bgColor shr 16) and $FF) +
469+
Chr((bgColor shr 8) and $FF) +
470+
Chr(bgColor and $FF);
465471
end;
472+
end;
466473

474+
function FlagsFromString(var str: String; out bgColor: Int32): EDebugLnFlags;
475+
var
476+
flagsByte: Byte;
477+
idx: Integer;
467478
begin
479+
Result := [];
468480
if (Length(Str) >= DebugLnFlagsHeaderLength) and (Str[1] = DebugLnFlagsHeader[1]) and (Str[2] = DebugLnFlagsHeader[2]) then
469481
begin
470-
Result := EDebugLnFlags(HexToInt(@Str[3]));
482+
flagsByte := Ord(str[3]);
483+
if (flagsByte and 1 <> 0) then Include(Result, EDebugLn.CLEAR);
484+
if (flagsByte and 2 <> 0) then Include(Result, EDebugLn.FOCUS);
485+
if (flagsByte and 4 <> 0) then Include(Result, EDebugLn.BACKGROUND_COLOR);
486+
//if (flagsByte and 8 <> 0) then Include(Result, EDebugLn.TEXT_COLOR);
487+
//maybe in the future... would like multi color support per line
488+
489+
idx := 4;
490+
if EDebugLn.BACKGROUND_COLOR in Result then
491+
begin
492+
bgColor := (Ord(Str[idx]) shl 16) or (Ord(str[idx+1]) shl 8) or Ord(str[idx+2]);
493+
Inc(idx, 3);
494+
end
495+
else
496+
bgColor := $0;
471497

472-
Delete(Str, 1, DebugLnFlagsHeaderLength);
473-
end else
474-
Result := [];
498+
Delete(str, 1, DebugLnFlagsHeaderLength);
499+
end;
475500
end;
476501

477502
function InRange(const AValue, AMin, AMax: Integer): Boolean;

0 commit comments

Comments
 (0)