paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-05 01:08:12 +02:00
Code Issues Packages Projects Releases Wiki Activity

Ide, TodoListLaz: Add IdeIntf for color scheme / Add "todo comment" markup for SourceEditor Issue #41420

Browse Source
This commit is contained in:
Martin 2025-03-18 19:59:44 +01:00
parent 4f387e226f
commit 900e58ed4f
10 changed files with 856 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
components/ideintf/editorsyntaxhighlighterdef.pas
View File

@ -44,7 +44,7 @@ const
IdeHighlighterUnknownId = TIdeSyntaxHighlighterID(-2); // Name not in list
IdeHighlighterNotSpecifiedId = TIdeSyntaxHighlighterID(-1); // No Name given
IdeHighlighterNoneID = TIdeSyntaxHighlighterID(0);
IdeHighlighterStartId = TIdeSyntaxHighlighterID(1); // first regulor Highlighter in IdeSyntaxHighlighters (lowest index)
IdeHighlighterStartId = TIdeSyntaxHighlighterID(1); // first regular Highlighter in IdeSyntaxHighlighters (lowest index)
LazSyntaxHighlighterNames: array[TLazSyntaxHighlighter] of String =
( 'None',
@ -73,8 +73,53 @@ const
function GetSyntaxHighlighterCaption(h: TLazSyntaxHighlighter): string; deprecated 'Use IdeSyntaxHighlighters (to be removed in 4.99)';
function StrToLazSyntaxHighlighter(const s: String): TLazSyntaxHighlighter; deprecated 'Use IdeSyntaxHighlighters (to be removed in 4.99)';
type
TColorSchemeAttributeFeature =
( hafBackColor, hafForeColor, hafFrameColor, hafAlpha, hafPrior,
hafStyle, hafStyleMask,
hafFrameStyle, hafFrameEdges,
hafMarkupFoldColor, // for the MarkupFoldColor module
hafCustomWords
);
TColorSchemeAttributeFeatures = set of TColorSchemeAttributeFeature;
IColorSchemeAttribute = interface ['{2572547D-217A-4A83-A910-0D808ECF3317}']
procedure ApplyTo(aDest: TObject);
end;
IColorSchemeLanguage = interface ['{40A0F5E1-ADD5-4E0E-BD14-583E244C4ACC}']
function GetName: String;
function AttributeCount: Integer;
function GetAttributeIntf(AnIndex: integer): IColorSchemeAttribute; //TSynHighlighterAttributesModifier
function GetAttributeIntf(const AStoredName: string): IColorSchemeAttribute; //TSynHighlighterAttributesModifier
end;
IColorScheme = interface ['{121AB166-7458-4AD8-8122-C9AD4A259521}']
function GetName: String;
function Count: integer;
function GetLanguage(AnIndex: Integer): IColorSchemeLanguage;
function GetLanguageForHighlighter(AnHiglighter: TObject): IColorSchemeLanguage;
function GetLanguageForHighlighter(AnHighlighterId: TIdeSyntaxHighlighterID): IColorSchemeLanguage;
end;
IColorSchemeList = interface ['{BA72F07B-77F5-4C36-AE9C-907980ADDEE3}']
function Count: integer;
function GetScheme(AnIndex: Integer): IColorScheme;
function GetScheme(AName: String): IColorScheme;
function GetCurrentSchemeForHighlighter(AnHiglighter: TObject): IColorScheme;
function GetCurrentSchemeForHighlighter(AnHighlighterId: TIdeSyntaxHighlighterID): IColorScheme;
procedure RegisterChangedHandler(AnHandler: TNotifyEvent);
procedure UnregisterChangedHandler(AnHandler: TNotifyEvent);
function RegisterAttributeGroup(AName: PString): integer; // pointer to resource string
procedure AddAttribute(AnAttrGroup: integer; AnHighlighterId: TIdeSyntaxHighlighterID; AStoredName: String; AName: PString; AFeatures: TColorSchemeAttributeFeatures; ADefaults: TObject = nil);
end;
var
IdeSyntaxHighlighters: TIdeSyntaxHighlighterList;
IdeColorSchemeList: IColorSchemeList;
implementation

20
components/synedit/synedithighlighter.pp
View File

@ -38,7 +38,7 @@ uses
// LazUtils
LazUTF8, LazMethodList,
// SynEdit
SynEditTypes, SynEditTextBase;
SynEditTypes, SynEditTextBase, SynEditMiscProcs;
type
{ TSynHighlighterRangeList }
@ -417,6 +417,7 @@ type
function IsKeyword(const AKeyword: string): boolean; virtual; // DJLP 2000-08-09
procedure Next; virtual; abstract;
procedure NextToEol;
function NextToLogX(ALogX: IntPos): boolean;
property DrawDivider[Index: integer]: TSynDividerDrawConfigSetting
read GetDrawDivider;
@ -1593,6 +1594,23 @@ begin
FIsInNextToEOL := False;
end;
function TSynCustomHighlighter.NextToLogX(ALogX: IntPos): boolean;
var
Start: Integer;
begin
Result := False;
while not GetEol do begin
Start := ToPos(GetTokenPos);
if Start > ALogX then
exit;
if ALogX < Start + GetTokenLen then begin
Result := True;
exit;
end;
Next;
end;
end;
procedure TSynCustomHighlighter.ContinueNextLine;
begin
inc(FLineIndex);

29
components/synedit/synhighlighterpas.pp
View File

@ -925,6 +925,9 @@ type
function GetTokenKind: integer; override;
function GetTokenPos: Integer; override;
function GetTokenLen: Integer; override;
function GetTokenIsComment: Boolean;
function GetTokenIsCommentStart(AnIgnoreMultiLineSlash: Boolean = False): Boolean;
function GetTokenIsCommentEnd: Boolean;
function IsKeyword(const AKeyword: string): boolean; override;
procedure Next; override;
@ -5197,6 +5200,7 @@ begin
#10: LFProc;
#13: CRProc;
else
FOldRange := fRange;
if rsAnsi in fRange then
AnsiProc
else if fRange * [rsBor, rsIDEDirective] <> [] then
@ -5207,7 +5211,6 @@ begin
SlashContinueProc
else begin
FNextTokenState := tsNone;
FOldRange := fRange;
OldNestLevel := PasCodeFoldRange.BracketNestLevel;
if (PasCodeFoldRange.BracketNestLevel = 1) then // procedure foo; [attr...]
FOldRange := FOldRange - [rsWasInProcHeader];
@ -5469,6 +5472,30 @@ begin
Result := Run-fTokenPos;
end;
function TSynPasSyn.GetTokenIsComment: Boolean;
begin
Result := (FTokenID = tkComment) or
( (fLineLen = 0) and
(FRange * [rsAnsi, rsBor] <> []) //rsIDEDirective
);
end;
function TSynPasSyn.GetTokenIsCommentStart(AnIgnoreMultiLineSlash: Boolean): Boolean;
begin
if AnIgnoreMultiLineSlash then
Result := (FTokenID = tkComment) and (fLineLen > 0) and
(FOldRange * [rsAnsi, rsBor] = []) // rsIDEDirective
else
Result := (FTokenID = tkComment) and (fLineLen > 0) and
(FOldRange * [rsAnsi, rsBor, rsSlash] = []);
end;
function TSynPasSyn.GetTokenIsCommentEnd: Boolean;
begin
Result := (FTokenID = tkComment) and
(FRange * [rsAnsi, rsBor, rsSlash] = []); // rsIDEDirective
end;
function TSynPasSyn.GetRange: Pointer;
begin
// For speed reasons, we work with fRange instead of CodeFoldRange.RangeType

8
components/todolist/todolistlaz.lpk
View File

@ -44,12 +44,20 @@
<Filename Value="todoliststrconsts.pas"/>
<UnitName Value="ToDoListStrConsts"/>
</Item>
<Item>
<Filename Value="todosynmarkup.pas"/>
<HasRegisterProc Value="True"/>
<UnitName Value="todosynmarkup"/>
</Item>
</Files>
<i18n>
<EnableI18N Value="True"/>
<OutDir Value="languages"/>
</i18n>
<RequiredPkgs>
<Item>
<PackageName Value="SynEdit"/>
</Item>
<Item>
<PackageName Value="IDEIntf"/>
</Item>

3
components/todolist/todolistlaz.pas
View File

@ -8,13 +8,14 @@ unit ToDoListLaz;
interface
uses
ToDoDlg, ToDoList, ToDoListCore, ToDoListStrConsts, LazarusPackageIntf;
ToDoDlg, ToDoList, ToDoListCore, ToDoListStrConsts, TodoSynMarkup, LazarusPackageIntf;
implementation
procedure Register;
begin
RegisterUnit('ToDoDlg', @ToDoDlg.Register);
RegisterUnit('TodoSynMarkup', @TodoSynMarkup.Register);
end;
initialization

547
components/todolist/todosynmarkup.pas Normal file
View File

@ -0,0 +1,547 @@
unit TodoSynMarkup;
{$mode objfpc}{$H+}
{$inline off}
interface
uses
Classes, SysUtils, Controls, Graphics,
LazLoggerBase,
// IdeIntf
SrcEditorIntf, EditorSyntaxHighlighterDef,
// LazEdit
LazEditMiscProcs,
// SynEdit
SynEditMarkup, SynHighlighterPas, SynEditMiscProcs, SynEdit, SynEditMiscClasses, SynEditTypes,
SynEditHighlighter;
type
{ TSynEditTodoMarkup }
TSynEditTodoMarkup = class(TSynEditMarkup)
private type
TCommentKind = (ckTodo, ckDone, ckNote);
TFoundTodo = record
StartPos: TLogPoint;
EndPos: TLogPoint;
Kind: TCommentKind;
end;
private
FPasHl: TSynPasSyn;
FLineLen: integer;
FFoundPos: array of TFoundTodo;
FSkipStartLine, FSkipEndLine: integer;
FNxtIdx, FMrkIdx: integer;
public
procedure BeginMarkup; override;
procedure PrepareMarkupForRow(aRow: Integer); override;
procedure GetNextMarkupColAfterRowCol(const aRow: Integer;
const aStartCol: TLazSynDisplayTokenBound; const AnRtlInfo: TLazSynDisplayRtlInfo; out
ANextPhys, ANextLog: Integer); override;
function GetMarkupAttributeAtRowCol(const aRow: Integer;
const aStartCol: TLazSynDisplayTokenBound; const AnRtlInfo: TLazSynDisplayRtlInfo
): TSynSelectedColor; override;
function GetMarkupAttributeAtWrapEnd(const aRow: Integer;
const aWrapCol: TLazSynDisplayTokenBound): TSynSelectedColor; override;
end;
procedure Register;
implementation
type
{ TTodoEditorHandler }
TTodoEditorHandler = class
procedure DoEditorCreated(Sender: TObject);
procedure DoColorsChanged(Sender: TObject);
end;
resourcestring
AttribGroupName = 'Todo comments';
AttribNameTodo = 'Todo comment';
AttribNameDone = 'Done comment';
AttribNameNote = 'Note comment';
var
AttribGroupIdx: Integer;
CommentAttribTodo, CommentAttribDone, CommentAttribNote: TSynSelectedColor;
procedure Register;
begin
SourceEditorManagerIntf.RegisterChangeEvent(semEditorCreate, @TTodoEditorHandler(nil).DoEditorCreated);
SourceEditorManagerIntf.RegisterChangeEvent(semEditorCloned, @TTodoEditorHandler(nil).DoEditorCreated);
TTodoEditorHandler(nil).DoColorsChanged(nil);
end;
procedure RegisterAttribs;
var
pas: TIdeSyntaxHighlighterID;
begin
CommentAttribTodo := TSynSelectedColor.Create('', '');
CommentAttribDone := TSynSelectedColor.Create('', '');
CommentAttribNote := TSynSelectedColor.Create('', '');
CommentAttribTodo.Clear;
CommentAttribDone.Clear;
CommentAttribNote.Clear;
IdeColorSchemeList.RegisterChangedHandler(@TTodoEditorHandler(nil).DoColorsChanged);
// Register colors before the IDE loads them
pas := IdeSyntaxHighlighters.GetIdForLazSyntaxHighlighter(lshFreePascal);
AttribGroupIdx := IdeColorSchemeList.RegisterAttributeGroup(@AttribGroupName);
IdeColorSchemeList.AddAttribute(AttribGroupIdx, pas, 'LazTodoListCommentTodo', @AttribNameTodo, [hafBackColor..hafFrameEdges]);
IdeColorSchemeList.AddAttribute(AttribGroupIdx, pas, 'LazTodoListCommentDone', @AttribNameDone, [hafBackColor..hafFrameEdges]);
IdeColorSchemeList.AddAttribute(AttribGroupIdx, pas, 'LazTodoListCommentNote', @AttribNameNote, [hafBackColor..hafFrameEdges]);
end;
procedure FreeAttribs;
begin
CommentAttribTodo.Free;
CommentAttribDone.Free;
CommentAttribNote.Free;
end;
{ TTodoEditorHandler }
procedure TTodoEditorHandler.DoEditorCreated(Sender: TObject);
var
Syn: TSynEdit;
begin
Syn := TSourceEditorInterface(Sender).EditorControl as TSynEdit;
Syn.MarkupManager.AddMarkUp(TSynEditTodoMarkup.Create(Syn));
end;
procedure TTodoEditorHandler.DoColorsChanged(Sender: TObject);
var
pas: TIdeSyntaxHighlighterID;
cs: IColorScheme;
csl: IColorSchemeLanguage;
attr: IColorSchemeAttribute;
begin
pas := IdeSyntaxHighlighters.GetIdForLazSyntaxHighlighter(lshFreePascal);
cs := IdeColorSchemeList.GetCurrentSchemeForHighlighter(pas);
csl := cs.GetLanguageForHighlighter(pas);
attr := csl.GetAttributeIntf('LazTodoListCommentTodo');
attr.ApplyTo(CommentAttribTodo);
attr := csl.GetAttributeIntf('LazTodoListCommentDone');
attr.ApplyTo(CommentAttribDone);
attr := csl.GetAttributeIntf('LazTodoListCommentNote');
attr.ApplyTo(CommentAttribNote);
end;
{ TSynEditTodoMarkup }
procedure TSynEditTodoMarkup.BeginMarkup;
begin
FFoundPos := nil;
FSkipStartLine := -1;
inherited BeginMarkup;
FPasHl := TSynPasSyn(TSynEdit(SynEdit).Highlighter);
if (FPasHl <> nil) and not(TSynCustomHighlighter(FPasHl) is TSynPasSyn) then
FPasHl := nil;
if not (CommentAttribTodo.IsEnabled or
CommentAttribDone.IsEnabled or
CommentAttribNote.IsEnabled)
then
FPasHl := nil;
end;
procedure TSynEditTodoMarkup.PrepareMarkupForRow(aRow: Integer);
var
LineText: String;
p: PChar;
pe: Pointer;
function GetLine(ALineNum: integer): boolean; inline;
begin
Result := False;
if ALineNum >= SynEdit.Lines.Count then
exit;
Result := True;
LineText := SynEdit.Lines[ToIdx(ALineNum)];
p := PChar(LineText);
pe := p + Length(LineText);
end;
function AdvanceToNextLine(var ALineNum: integer): boolean; inline;
begin
repeat
inc(ALineNum);
Result := GetLine(ALineNum);
until (not Result) or (LineText <> '');
end;
function StartsWithContinuedComment(ALineNum: integer): boolean; inline;
begin
FPasHl.StartAtLineIndex(ToIdx(ALineNum));
Result := FPasHl.GetTokenIsComment and
not FPasHl.GetTokenIsCommentStart(True);
end;
function GetStartOfComment(var ALineNum: integer; out ALogX: integer): boolean; inline;
var
IsComment, IsNewCommentStart: Boolean;
begin
ALogX := 1;
FPasHl.StartAtLineIndex(ToIdx(ALineNum));
Result := FPasHl.GetTokenIsComment;
if (not Result) or
(FPasHl.GetTokenIsCommentStart(True))
then
exit;
while ALineNum > 1 do begin
dec(ALineNum);
if ALineNum = FSkipEndLine then
exit(False);
FPasHl.StartAtLineIndex(ToIdx(ALineNum));
IsComment := FPasHl.GetTokenIsComment;
// if not a comment, then pretend its a new start => used for "result"
IsNewCommentStart := (not IsComment) or FPasHl.GetTokenIsCommentStart(True);
if IsComment and (not IsNewCommentStart) and FPasHl.GetEol then
continue;
Result := IsNewCommentStart;
while not FPasHl.GetEol do begin
if not IsComment then begin
ALogX := ToPos(FPasHl.GetTokenPos);
Result := True;
end;
FPasHl.Next;
IsComment := FPasHl.GetTokenIsComment;
end;
if Result then
exit;
end;
Result := False;
end;
var
curRow: integer;
StartPos: TPoint;
procedure MaybeSetSkipRows;
begin
if curRow > aRow then begin
FSkipStartLine := StartPos.Y + 1;
FSkipEndLine := curRow - 1;
end;
end;
var
fnd, firstRun, HasHash: Boolean;
LogX, TkEnd: integer;
Kind: TCommentKind;
pos: TPoint;
i: SizeInt;
begin
if FPasHl = nil then
exit;
FNxtIdx := 0;
FMrkIdx := 0;
FLineLen := Length(SynEdit.Lines[ToIdx(aRow)]);
if (FSkipStartLine >=0) and (FSkipStartLine <= aRow) and (FSkipEndLine >= aRow) then begin
FFoundPos := nil;
exit;
end;
curRow := aRow;
LogX := 1;
i := Length(FFoundPos) - 1;
if (i >= 0) and
(FFoundPos[i].StartPos.Y < aRow) and
(FFoundPos[i].EndPos.Y >= aRow - 1)
then begin
if (FFoundPos[i].EndPos.Y >= aRow) then begin
if i > 0 then
FFoundPos[0] := FFoundPos[i];
SetLength(FFoundPos, 1);
if FFoundPos[0].EndPos.Y > aRow then
exit;
LogX := FFoundPos[0].EndPos.X;
end
else
if StartsWithContinuedComment(aRow) then begin
if i > 0 then
FFoundPos[0] := FFoundPos[i];
SetLength(FFoundPos, 1);
TkEnd := 1 + FPasHl.GetTokenLen;
FFoundPos[0].EndPos.Y := aRow;
FFoundPos[0].EndPos.X := TkEnd;
LogX := TkEnd;
end
else
FFoundPos := nil;
end
else
FFoundPos := nil;
if (FFoundPos = nil) and (not GetStartOfComment(curRow, LogX)) then begin
curRow := aRow;
LogX := 1;
end;
GetLine(curRow);
if LineText = '' then
exit;
p := p + LogX - 1;
fnd := False;
firstRun := True;
repeat
if (not firstRun) and (curRow < aRow) then begin
// There was only one continuous comment in front of aRow => skip it;
curRow := aRow;
GetLine(curRow);
end;
firstRun := False;
(* *** find potential comment start *** *)
while p < pe do begin
case p^ of
'{': break;
'(': if p[1] = '*' then break;
'/': if p[1] = '/' then break;
end;
inc(p);
end;
if p >= pe then
exit;
StartPos.x := p - PChar(LineText) + 1;
StartPos.y := curRow;
case p^ of
'(', '/': inc(p, 2);
else inc(p);
end;
(* *** skip whitespace *** *)
repeat
p := p + CountLeadWhiteSpace(p);
if p >= pe then begin
if not AdvanceToNextLine(curRow) then begin
MaybeSetSkipRows;
exit;
end;
continue; // continue skip whitespace for new line
end;
break;
until false;
(* *** skip hash *** *)
HasHash := (p+5 < pe) and (p^ = '#'); // hash must be on same line as keyword
if HasHash then
inc(p);
(* *** keyword *** *)
if (p+4 <= pe) then begin
case p^ of
't', 'T': begin
Kind := ckTodo;
fnd := (p[1] in ['o', 'O']) and (p[2] in ['d', 'D']) and (p[3] in ['o', 'O']);
end;
'd', 'D': begin
Kind := ckDone;
fnd := (p[1] in ['o', 'O']) and (p[2] in ['n', 'N']) and (p[3] in ['e', 'E']);
end;
'n', 'N': begin
Kind := ckNote;
fnd := (p[1] in ['o', 'O']) and (p[2] in ['t', 'T']) and (p[3] in ['e', 'E']);
end;
end;
end;
if not fnd then begin
MaybeSetSkipRows;
Continue;
end;
fnd := False; // for next round, in case of several todo on one line
inc(p, 4);
if not ( (p = pe) or (p^ in [#9, #10, #13, ' ',':'])) then begin
MaybeSetSkipRows;
continue;
end;
(* *** Check arguments / parse *** *)
if not HasHash then begin
while p^ <> ':' do begin
while p^ in [#9, ' ', '0'..'9'] do
inc(p);
if p >= pe then begin
if not AdvanceToNextLine(curRow) then begin
MaybeSetSkipRows;
break;
end;
continue; // continue search for colon
end;
if (p^ = '-') and (p[1] in ['o', 'O', 'c', 'C']) then begin
if p[2] = '''' then begin
inc(p, 3);
while (p^ <> '''') do begin
inc(p);
if p >= pe then begin
if not AdvanceToNextLine(curRow) then begin
MaybeSetSkipRows;
break;
end;
continue; // continue search for quote
end;
end;
inc(p);
end
else
begin
inc(p, 2);
while (p < pe) and not(p^ in [#9, ' ', ':']) do
inc(p);
end;
continue; // continue search for colon
end;
break; // not allowed char
end;
if p^ <> ':' then begin
MaybeSetSkipRows;
continue;
end;
end;
(* *** found *** *)
assert(StartPos.Y <= aRow, 'TSynEditTodoMarkup.PrepareMarkupForRow: StartPos.Y <= aRow');
if (StartPos.Y = aRow) then begin
FPasHl.StartAtLineIndex(ToIdx(StartPos.Y));
FPasHl.NextToLogX(StartPos.X);
if (ToPos(FPasHl.GetTokenPos) <> StartPos.x) or (not FPasHl.GetTokenIsCommentStart(True)) then begin
MaybeSetSkipRows;
Continue;
end;
end;
if curRow < aRow then begin
curRow := aRow;
GetLine(curRow);
end;
pos.Y := curRow;
pos.x := 1;
if StartPos.Y = curRow then
pos.X := StartPos.x;
if (StartPos.Y <> aRow) or
(StartPos.Y <> pos.Y) or (StartPos.X > pos.X)
then
FPasHl.StartAtLineIndex(ToIdx(pos.Y));
FPasHl.NextToLogX(pos.X);
TkEnd := ToPos(FPasHl.GetTokenPos) + FPasHl.GetTokenLen;
i := Length(FFoundPos);
SetLength(FFoundPos, i + 1);
FFoundPos[i].StartPos := StartPos;
FFoundPos[i].EndPos.y := curRow;
FFoundPos[i].EndPos.x := TkEnd;
FFoundPos[i].Kind := Kind;
p := PChar(LineText) + TkEnd - 1;
until (p >= pe) or (curRow > aRow);
end;
procedure TSynEditTodoMarkup.GetNextMarkupColAfterRowCol(const aRow: Integer;
const aStartCol: TLazSynDisplayTokenBound; const AnRtlInfo: TLazSynDisplayRtlInfo; out
ANextPhys, ANextLog: Integer);
begin
ANextLog := -1;
ANextPhys := -1;
if (Length(FFoundPos) > 0) and (aStartCol.Logical < FLineLen + 1) then
ANextLog := FLineLen + 1;
while (FNxtIdx < Length(FFoundPos)) do begin
if (FFoundPos[FNxtIdx].StartPos.X > aStartCol.Logical) then begin
ANextLog := FFoundPos[FNxtIdx].StartPos.X;
exit;
end
else
if (FFoundPos[FNxtIdx].EndPos.X > aStartCol.Logical) and
(FFoundPos[FNxtIdx].EndPos.y = aRow)
then begin
ANextLog := FFoundPos[FNxtIdx].EndPos.X;
exit;
end;
inc(FNxtIdx);
end;
end;
function TSynEditTodoMarkup.GetMarkupAttributeAtRowCol(const aRow: Integer;
const aStartCol: TLazSynDisplayTokenBound; const AnRtlInfo: TLazSynDisplayRtlInfo
): TSynSelectedColor;
begin
Result := nil;
if aStartCol.Logical > FLineLen then
exit;
while (Result = nil) and (FMrkIdx < Length(FFoundPos)) do begin
if (FFoundPos[FMrkIdx].StartPos.X > aStartCol.Logical) and
(FFoundPos[FMrkIdx].StartPos.Y = aRow)
then
exit;
if (FFoundPos[FMrkIdx].EndPos.X > aStartCol.Logical) or
(FFoundPos[FMrkIdx].EndPos.y > aRow)
then begin
case FFoundPos[FMrkIdx].Kind of
ckTodo: Result := CommentAttribTodo;
ckDone: Result := CommentAttribDone;
else Result := CommentAttribNote;
end;
exit;
end;
inc(FMrkIdx);
end;
end;
function TSynEditTodoMarkup.GetMarkupAttributeAtWrapEnd(const aRow: Integer;
const aWrapCol: TLazSynDisplayTokenBound): TSynSelectedColor;
begin
Result := nil;
if aWrapCol.Logical > FLineLen then
exit;
while (Result = nil) and (FMrkIdx < Length(FFoundPos)) do begin
if (FFoundPos[FMrkIdx].StartPos.X > aWrapCol.Logical) and
(FFoundPos[FMrkIdx].StartPos.Y = aRow)
then
exit;
if (FFoundPos[FMrkIdx].EndPos.X > aWrapCol.Logical) or
(FFoundPos[FMrkIdx].EndPos.y > aRow)
then begin
case FFoundPos[FMrkIdx].Kind of
ckTodo: Result := CommentAttribTodo;
ckDone: Result := CommentAttribDone;
else Result := CommentAttribNote;
end;
exit;
end;
inc(FMrkIdx);
end;
end;
initialization
RegisterAttribs;
finalization
FreeAttribs;
end.

214
ide/editoroptions.pp
View File

@ -42,7 +42,7 @@ uses
// RTL, FCL
Classes, SysUtils, typinfo, fgl, Math, resource,
// LCL
Graphics, LResources, Forms, Dialogs, ComCtrls, LCLType, Controls,
Graphics, LResources, Forms, Dialogs, ComCtrls, LCLType, Controls, LCLProc,
// LazUtils
FileUtil, LazFileUtils, LazUTF8, LazClasses, Laz2_XMLCfg, LazStringUtils, LazLoggerBase,
// Synedit
@ -96,15 +96,6 @@ type
TLazSynPluginSyncroEditForm = class(TForm) end;
TLazSynPluginSyncroEditFormOff = class(TForm) end;
TColorSchemeAttributeFeature =
( hafBackColor, hafForeColor, hafFrameColor, hafAlpha, hafPrior,
hafStyle, hafStyleMask,
hafFrameStyle, hafFrameEdges,
hafMarkupFoldColor, // for the MarkupFoldColor module
hafCustomWords
);
TColorSchemeAttributeFeatures = set of TColorSchemeAttributeFeature;
const
SynEditPreviewIncludeOptions = [eoNoCaret, eoNoSelection];
SynEditPreviewExcludeOptions = [eoDragDropEditing, eoDropFiles,
@ -331,10 +322,11 @@ type
{ TColorSchemeAttribute }
TColorSchemeAttribute = class(TSynHighlighterLazCustomPasAttribute)
TColorSchemeAttribute = class(TSynHighlighterLazCustomPasAttribute, IColorSchemeAttribute)
private
FFeatures: TColorSchemeAttributeFeatures;
FGroup: TAhaGroupName;
FRegisteredGroup: integer;
FMarkupFoldLineAlpha: Byte;
FMarkupFoldLineColor: TColor;
FMarkupFoldLineStyle: TSynLineStyle;
@ -342,10 +334,13 @@ type
FAlreadyGotSchemeGlobal: Boolean;
FSchemeGlobalCache: TColorSchemeAttribute;
FUseSchemeGlobals: Boolean;
function GetGroupName: String;
function GetIsUsingSchemeGlobals: Boolean;
procedure SetMarkupFoldLineAlpha(AValue: Byte);
procedure SetMarkupFoldLineColor(AValue: TColor);
procedure SetMarkupFoldLineStyle(AValue: TSynLineStyle);
// IColorSchemeAttribute
procedure ApplyTo(aDest: TObject);
protected
procedure Init; override;
public
@ -363,6 +358,7 @@ type
procedure SaveToXml(aXMLConfig: TRttiXMLConfig; const aPath: String;
Defaults: TColorSchemeAttribute);
property Group: TAhaGroupName read FGroup write FGroup;
property GroupName: String read GetGroupName;
property IsUsingSchemeGlobals: Boolean read GetIsUsingSchemeGlobals;
property Features: TColorSchemeAttributeFeatures read FFeatures write FFeatures;
published
@ -375,7 +371,7 @@ type
{ TColorSchemeLanguage }
TColorSchemeLanguage = class(TObject)
TColorSchemeLanguage = class(TObject, IColorSchemeLanguage)
private
FDefaultAttribute: TColorSchemeAttribute;
FAttributes: TQuickStringlist; // TColorSchemeAttribute
@ -391,6 +387,9 @@ type
function GetName: String;
function DoesSupportGroup(AGroup: TAhaGroupName): boolean;
function GetSupportsFileExt: Boolean;
// IColorSchemeLanguage
function GetAttributeIntf(AnIndex: integer): IColorSchemeAttribute;
function GetAttributeIntf(const AStoredName: string): IColorSchemeAttribute;
public
constructor Create(AGroup: TColorScheme; AIdeHighlighterID: TIdeSyntaxHighlighterID;
IsSchemeDefault: Boolean);
@ -426,39 +425,58 @@ type
{ TColorScheme }
TColorScheme = class(TObject)
TColorScheme = class(TObject, IColorScheme)
private type
TColorSchemesMap = specialize TFPGMapObject<string, TColorSchemeLanguage>;
private
FName: String;
FColorSchemes: TColorSchemesMap; //Array of TColorSchemeLanguage;
FDefaultColors: TColorSchemeLanguage;
function GetColorScheme(Index: integer): TColorSchemeLanguage;
function GetColorSchemeBySynHl(Index: TSynCustomHighlighter): TColorSchemeLanguage;
// IColorScheme
function GetName: String;
function GetLanguage(AnIndex: Integer): IColorSchemeLanguage;
function GetLanguageForHighlighter(AnHiglighter: TObject {TSynCustomHighlighter}): IColorSchemeLanguage;
function GetLanguageForHighlighter(AnHighlighterId: TIdeSyntaxHighlighterID): IColorSchemeLanguage;
public
constructor Create(const AName: String);
constructor CreateFromXml(aXMLConfig: TRttiXMLConfig; const AName, aPath: String);
destructor Destroy; override;
procedure Assign(Src: TColorScheme); reintroduce;
function Count: integer;
function GetStoredValuesForScheme: TColorScheme; // The IDE default colors from the resources
procedure LoadFromXml(aXMLConfig: TRttiXMLConfig; const aPath: String;
Defaults: TColorScheme; const aOldPath: String = '');
procedure SaveToXml(aXMLConfig: TRttiXMLConfig; const aPath: String; Defaults: TColorScheme);
property Name: string read FName;
property DefaultColors: TColorSchemeLanguage read FDefaultColors;
property ColorScheme[Index: integer]: TColorSchemeLanguage read GetColorScheme;
property ColorSchemeBySynHl[Index: TSynCustomHighlighter]: TColorSchemeLanguage read GetColorSchemeBySynHl;
end;
{ TColorSchemeFactory }
TColorSchemeFactory = class(TObject)
TColorSchemeFactory = class(TObject, IColorSchemeList)
private
FMappings: TQuickStringlist; // TColorScheme
function GetColorSchemeGroup(const Index: String): TColorScheme;
function GetColorSchemeGroupAtPos(Index: Integer): TColorScheme;
// IColorSchemeList
function GetScheme(AnIndex: Integer): IColorScheme;
function GetScheme(AName: String): IColorScheme;
function GetCurrentSchemeForHighlighter(AnHiglighter: TObject {TSynCustomHighlighter}): IColorScheme;
function GetCurrentSchemeForHighlighter(AnHighlighterId: TIdeSyntaxHighlighterID): IColorScheme;
procedure RegisterChangedHandler(AnHandler: TNotifyEvent);
procedure UnregisterChangedHandler(AnHandler: TNotifyEvent);
function RegisterAttributeGroup(AName: PString): integer; // pointer to resource string
procedure InternalAddAttribute(AnAttrGroup: integer; AnHighlighterId: TIdeSyntaxHighlighterID; AStoredName: String; AName: PString; AFeatures: TColorSchemeAttributeFeatures; ADefaults: TObject = nil);
procedure AddAttribute(AnAttrGroup: integer; AnHighlighterId: TIdeSyntaxHighlighterID; AStoredName: String; AName: PString; AFeatures: TColorSchemeAttributeFeatures; ADefaults: TObject = nil);
public
constructor Create;
destructor Destroy; override;
procedure Clear;
function Count: integer;
procedure Assign(Src: TColorSchemeFactory); reintroduce;
procedure LoadFromXml(aXMLConfig: TRttiXMLConfig; const aPath: String;
Defaults: TColorSchemeFactory; const aOldPath: String = '');
@ -1880,6 +1898,7 @@ type
fMultiWinEditAccessOrder: TEditorOptionsEditAccessOrderList;
// Default values for RttiXmlConfig using published properties.
FDefaultValues: TEditorOptionsDefaults;
function GetHighlighterList: TEditOptLangList;
procedure Init;
function GetCodeTemplateFileNameExpand: String;
@ -1890,6 +1909,7 @@ type
class function GetGroupCaption: string; override;
class function GetInstance: TAbstractIDEOptions; override;
procedure DoAfterWrite(Restore: boolean); override;
procedure DoAfterRead; override;
public
constructor Create;
destructor Destroy; override;
@ -2058,6 +2078,8 @@ const
var
DefaultColorSchemeName: String;
EdOptsChangedHandlers: TMethodList;
RegisteredAttribGroupNames: array of PString;
function FontHeightToSize(Height: Integer): Integer;
var
@ -5614,6 +5636,15 @@ begin
if not Restore then
Save;
inherited;
if EdOptsChangedHandlers <> nil then
EdOptsChangedHandlers.CallNotifyEvents(nil);
end;
procedure TEditorOptions.DoAfterRead;
begin
inherited DoAfterRead;
if EdOptsChangedHandlers <> nil then
EdOptsChangedHandlers.CallNotifyEvents(nil);
end;
constructor TEditorOptions.Create;
@ -7073,6 +7104,11 @@ begin
Changed;
end;
procedure TColorSchemeAttribute.ApplyTo(aDest: TObject);
begin
ApplyTo(aDest as TSynHighlighterAttributes, nil);
end;
procedure TColorSchemeAttribute.Init;
begin
inherited Init;
@ -7087,6 +7123,14 @@ begin
Result := FUseSchemeGlobals and (GetSchemeGlobal <> nil);
end;
function TColorSchemeAttribute.GetGroupName: String;
begin
if FGroup = agnRegistered then
Result := RegisteredAttribGroupNames[FRegisteredGroup]^
else
Result := AdditionalHighlightGroupNames[Group];
end;
function TColorSchemeAttribute.GetSchemeGlobal: TColorSchemeAttribute;
begin
if FAlreadyGotSchemeGlobal then
@ -7369,6 +7413,16 @@ begin
Result := (FHighlighter = nil) or not(FHighlighter is TNonSrcIDEHighlighter);
end;
function TColorSchemeLanguage.GetAttributeIntf(AnIndex: integer): IColorSchemeAttribute;
begin
Result := GetAttributeAtPos(AnIndex);
end;
function TColorSchemeLanguage.GetAttributeIntf(const AStoredName: string): IColorSchemeAttribute;
begin
Result := GetAttribute(AStoredName);
end;
function TColorSchemeLanguage.GetStoredValuesForLanguage: TColorSchemeLanguage;
var
cs: TColorScheme;
@ -7944,6 +7998,32 @@ begin
Result := FColorSchemes[Index.LanguageName];
end;
function TColorScheme.GetName: String;
begin
Result := FName;
end;
function TColorScheme.GetLanguage(AnIndex: Integer): IColorSchemeLanguage;
begin
Result := FColorSchemes.Data[AnIndex];
end;
function TColorScheme.GetLanguageForHighlighter(AnHighlighterId: TIdeSyntaxHighlighterID
): IColorSchemeLanguage;
begin
Result := ColorSchemeBySynHl[HighlighterList.SharedSynInstances[AnHighlighterId]];
end;
function TColorScheme.GetLanguageForHighlighter(AnHiglighter: TObject): IColorSchemeLanguage;
begin
Result := ColorSchemeBySynHl[AnHiglighter as TSynCustomHighlighter];
end;
function TColorScheme.GetColorScheme(Index: integer): TColorSchemeLanguage;
begin
Result := FColorSchemes.Data[Index];
end;
function TColorScheme.GetStoredValuesForScheme: TColorScheme;
begin
Result:=ColorSchemeFactory.ColorSchemeGroup[Name];
@ -8002,6 +8082,11 @@ begin
end;
end;
function TColorScheme.Count: integer;
begin
Result := FColorSchemes.Count;
end;
procedure TColorScheme.LoadFromXml(aXMLConfig: TRttiXMLConfig;
const aPath: String; Defaults: TColorScheme; const aOldPath: String);
var
@ -8070,6 +8155,98 @@ begin
Result := TColorScheme(FMappings.Objects[Index]);
end;
function TColorSchemeFactory.GetScheme(AnIndex: Integer): IColorScheme;
begin
Result := nil;
if EditorOpts <> nil then
Result := EditorOpts.UserColorSchemeGroup.ColorSchemeGroupAtPos[AnIndex];
end;
function TColorSchemeFactory.GetScheme(AName: String): IColorScheme;
begin
Result := nil;
if EditorOpts <> nil then
Result := EditorOpts.UserColorSchemeGroup.ColorSchemeGroup[AName];
end;
function TColorSchemeFactory.GetCurrentSchemeForHighlighter(AnHiglighter: TObject): IColorScheme;
begin
Result := nil;
if EditorOpts <> nil then
Result := EditorOpts.UserColorSchemeGroup.GetColorSchemeGroup(EditorOpts.ReadColorScheme((AnHiglighter as TSynCustomHighlighter).LanguageName));
end;
function TColorSchemeFactory.GetCurrentSchemeForHighlighter(AnHighlighterId: TIdeSyntaxHighlighterID
): IColorScheme;
begin
Result := nil;
if EditorOpts <> nil then
Result := EditorOpts.UserColorSchemeGroup.GetColorSchemeGroup(EditorOpts.ReadColorScheme(HighlighterList.Names[AnHighlighterId]));
end;
procedure TColorSchemeFactory.RegisterChangedHandler(AnHandler: TNotifyEvent);
begin
if EdOptsChangedHandlers = nil then
EdOptsChangedHandlers := TMethodList.Create;
EdOptsChangedHandlers.Add(TMethod(AnHandler));
end;
procedure TColorSchemeFactory.UnregisterChangedHandler(AnHandler: TNotifyEvent);
begin
if EdOptsChangedHandlers <> nil then
EdOptsChangedHandlers.Remove(TMethod(AnHandler));
end;
function TColorSchemeFactory.RegisterAttributeGroup(AName: PString): integer;
begin
Result := Length(RegisteredAttribGroupNames);
SetLength(RegisteredAttribGroupNames, Result + 1);
RegisteredAttribGroupNames[Result] := AName;
end;
procedure TColorSchemeFactory.InternalAddAttribute(AnAttrGroup: integer;
AnHighlighterId: TIdeSyntaxHighlighterID; AStoredName: String; AName: PString;
AFeatures: TColorSchemeAttributeFeatures; ADefaults: TObject);
var
h: TSynCustomHighlighter;
i: Integer;
cs: TColorScheme;
csl: TColorSchemeLanguage;
csa: TColorSchemeAttribute;
begin
h := HighlighterList.SharedSynInstances[AnHighlighterId];
if h = nil then
exit;
for i := 0 to FMappings.Count - 1 do begin
cs := ColorSchemeGroupAtPos[i];
csl := cs.ColorSchemeBySynHl[h];
if csl = nil then
continue;
csa := TColorSchemeAttribute.Create(csl, AName, AStoredName);
csa.Clear;
if ADefaults <> nil then
csa.AssignColors(ADefaults as TSynHighlighterAttributes);
csa.InternalSaveDefaultValues;
csa.FGroup := agnRegistered;
csa.FRegisteredGroup := AnAttrGroup;
csa.FFeatures := AFeatures;
csl.FAttributes.AddObject(AStoredName, csa);
end;
end;
procedure TColorSchemeFactory.AddAttribute(AnAttrGroup: integer;
AnHighlighterId: TIdeSyntaxHighlighterID; AStoredName: String; AName: PString;
AFeatures: TColorSchemeAttributeFeatures; ADefaults: TObject);
begin
InternalAddAttribute(AnAttrGroup, AnHighlighterId, AStoredName, AName, AFeatures, ADefaults);
if EditorOpts <> nil then
EditorOpts.UserColorSchemeGroup.InternalAddAttribute(AnAttrGroup, AnHighlighterId, AStoredName, AName, AFeatures, ADefaults);
end;
constructor TColorSchemeFactory.Create;
begin
inherited Create;
@ -8096,6 +8273,11 @@ begin
end;
end;
function TColorSchemeFactory.Count: integer;
begin
Result := FMappings.Count;
end;
procedure TColorSchemeFactory.Assign(Src: TColorSchemeFactory);
var
lMapping: TColorScheme;
@ -8254,9 +8436,13 @@ end;
initialization
RegisterIDEOptionsGroup(GroupEditor, TEditorOptions);
IdeSyntaxHighlighters := HighlighterList;
IdeColorSchemeList := ColorSchemeFactory;
finalization
IdeColorSchemeList := nil;
ColorSchemeFactory.Free;
HighlighterList.Free;
RegisteredAttribGroupNames := nil;
EdOptsChangedHandlers.Free;
end.

4
ide/frames/editor_color_options.pas
View File

@ -1183,7 +1183,7 @@ begin
else
ColorElementTree.Items.Add(nil, AdditionalHighlightGroupNames[agnDefault]);
for j := low(TAhaGroupName) to high(TAhaGroupName) do
if not(j in [agnDefault, agnLanguage]) then
if not(j in [agnDefault, agnLanguage, agnRegistered]) then
ColorElementTree.Items.Add(nil, AdditionalHighlightGroupNames[j]).Visible := False;
// Fill Attributes in
@ -1216,7 +1216,7 @@ begin
else
begin
AttriIdx := GetEnumValue(TypeInfo(TAdditionalHilightAttribute), Attr.StoredName);
ParentName := AdditionalHighlightGroupNames[Attr.Group];
ParentName := Attr.GroupName;
ParentNode := ColorElementTree.Items.FindTopLvlNode(ParentName);
if (AttriIdx >= ord(ahaIdentComplWindowEntryVar)) and (AttriIdx <= ord(ahaIdentComplWindowEntryUnknown))
then begin

3
ide/sourcemarks.pas
View File

@ -81,7 +81,8 @@ type
TAhaGroupName = (
agnDefault, agnLanguage, agnText, agnLine, agnGutter, agnWrap,
agnTemplateMode, agnSyncronMode,
agnIfDef, agnIdentComplWindow, agnOutlineColors
agnIfDef, agnIdentComplWindow, agnOutlineColors,
agnRegistered
);
TSourceEditorBase = class;

2
ide/syncolorattribeditor.pas
View File

@ -9,6 +9,8 @@ uses
// LCL
LCLIntf, Forms, StdCtrls, ExtCtrls, Graphics, GraphUtil,
ColorBox, Dialogs, Menus, Spin,
// IdeIntf
EditorSyntaxHighlighterDef,
// SynEdit
SynEditTypes, SynTextDrawer, SynHighlighterPas,
// IdeConfig