1 {
2 Copyright (C) Alexey Torgashin, uvviewsoft.com
3 License: MPL 2.0 or LGPL
4 }
5 unit ATSynEdit_Adapter_LiteLexer;
6
7 {$mode objfpc}{$H+}
8
9 interface
10
11 uses
12 Classes, SysUtils, Graphics, Forms, Dialogs,
13 ATSynEdit,
14 ATSynEdit_Adapters,
15 ATSynEdit_LineParts,
16 ATSynEdit_CanvasProc,
17 Masks,
18 FileUtil,
19 at__jsonConf,
20 ec_RegExpr,
21 math;
22
23 type
24 { TATLiteLexerRule }
25
26 TATLiteLexerRule = class
27 public
28 Name: string;
29 Style: string;
30 StyleHash: integer;
31 RegexObj: array[boolean] of TecRegExpr;
32 constructor Create(const AName, AStyle, ARegex: string; ACaseSens: boolean); virtual;
33 destructor Destroy; override;
34 end;
35
36 type
37 TATLiteLexer_GetStyleHash = function (const AStyleName: string): integer;
38 TATLiteLexer_ApplyStyle = procedure (AStyleHash: integer; var APart: TATLinePart);
39
40 type
41 { TATLiteLexer }
42
43 TATLiteLexer = class(TATAdapterHilite)
44 private
45 FRules: TFPList;
46 FOnGetStyleHash: TATLiteLexer_GetStyleHash;
47 FOnApplyStyle: TATLiteLexer_ApplyStyle;
48 //calc tokens not from ACharIndex, but from n chars lefter,
49 //to hilite comments/strings, partly scrolled to left
GetRulenull50 function GetRule(AIndex: integer): TATLiteLexerRule;
51 public
52 LexerName: string;
53 FileTypes: string;
54 CaseSens: boolean;
55 ConsiderSpaces: boolean;
56 CommentLine: string;
57 CommentBlockBegin: string;
58 CommentBlockEnd: string;
59 constructor Create(AOnwer: TComponent); override;
60 destructor Destroy; override;
GetLexerNamenull61 function GetLexerName: string; override;
62 procedure Clear;
63 procedure LoadFromFile(const AFilename: string);
IsFilenameMatchnull64 function IsFilenameMatch(const AFilename: string): boolean;
RuleCountnull65 function RuleCount: integer;
66 property Rules[AIndex: integer]: TATLiteLexerRule read GetRule;
Dumpnull67 function Dump: string;
68 procedure OnEditorCalcHilite(Sender: TObject; var AParts: TATLineParts;
69 ALineIndex, ACharIndex, ALineLen: integer; var AColorAfterEol: TColor;
70 AMainText: boolean); override;
71 property OnGetStyleHash: TATLiteLexer_GetStyleHash read FOnGetStyleHash write FOnGetStyleHash;
72 property OnApplyStyle: TATLiteLexer_ApplyStyle read FOnApplyStyle write FOnApplyStyle;
73 end;
74
75 type
76 { TATLiteLexers }
77
78 TATLiteLexers = class(TComponent)
79 private
80 FList: TFPList;
81 FOnGetStyleHash: TATLiteLexer_GetStyleHash;
82 FOnApplyStyle: TATLiteLexer_ApplyStyle;
GetLexernull83 function GetLexer(AIndex: integer): TATLiteLexer;
84 public
85 constructor Create(AOwner: TComponent); override;
86 destructor Destroy; override;
87 procedure Clear;
88 procedure LoadFromDir(const ADir: string);
LexerCountnull89 function LexerCount: integer;
90 property Lexers[AIndex: integer]: TATLiteLexer read GetLexer;
Addnull91 function Add(const ALexerName, AFileTypes, ACommentLine, ACommentBlockBegin,
92 ACommentBlockEnd: string): boolean;
FindLexerByFilenamenull93 function FindLexerByFilename(AFilename: string): TATLiteLexer;
FindLexerByNamenull94 function FindLexerByName(const AName: string): TATLiteLexer;
95 property OnGetStyleHash: TATLiteLexer_GetStyleHash read FOnGetStyleHash write FOnGetStyleHash;
96 property OnApplyStyle: TATLiteLexer_ApplyStyle read FOnApplyStyle write FOnApplyStyle;
97 end;
98
99 implementation
100
101 { TATLiteLexers }
102
103 constructor TATLiteLexers.Create(AOwner: TComponent);
104 begin
105 inherited;
106 FList:= TFPList.Create;
107 end;
108
109 destructor TATLiteLexers.Destroy;
110 begin
111 Clear;
112 FreeAndNil(FList);
113 inherited;
114 end;
115
116 procedure TATLiteLexers.Clear;
117 var
118 i: integer;
119 begin
120 for i:= FList.Count-1 downto 0 do
121 TObject(FList[i]).Free;
122 FList.Clear;
123 end;
124
TATLiteLexers.LexerCountnull125 function TATLiteLexers.LexerCount: integer;
126 begin
127 Result:= FList.Count;
128 end;
129
Addnull130 function TATLiteLexers.Add(const ALexerName, AFileTypes,
131 ACommentLine, ACommentBlockBegin, ACommentBlockEnd: string): boolean;
132 var
133 Lexer: TATLiteLexer;
134 begin
135 Result:= FindLexerByName(ALexerName)=nil;
136 if Result then
137 begin
138 Lexer:= TATLiteLexer.Create(nil);
139 Lexer.LexerName:= ALexerName;
140 Lexer.FileTypes:= AFileTypes;
141 Lexer.CommentLine:= ACommentLine;
142 Lexer.CommentBlockBegin:= ACommentBlockBegin;
143 lexer.CommentBlockEnd:= ACommentBlockEnd;
144 FList.Add(Lexer);
145 end;
146 end;
147
TATLiteLexers.GetLexernull148 function TATLiteLexers.GetLexer(AIndex: integer): TATLiteLexer;
149 begin
150 Result:= TATLiteLexer(FList[AIndex]);
151 end;
152
FindLexerByFilenamenull153 function TATLiteLexers.FindLexerByFilename(AFilename: string): TATLiteLexer;
154 var
155 Lexer: TATLiteLexer;
156 i: integer;
157 begin
158 Result:= nil;
159 AFilename:= ExtractFileName(AFilename);
160 for i:= 0 to LexerCount-1 do
161 begin
162 Lexer:= Lexers[i];
163 if Lexer.IsFilenameMatch(AFileName) then
164 exit(Lexer);
165 end;
166 end;
167
FindLexerByNamenull168 function TATLiteLexers.FindLexerByName(const AName: string): TATLiteLexer;
169 var
170 Lexer: TATLiteLexer;
171 i: integer;
172 begin
173 Result:= nil;
174 for i:= 0 to LexerCount-1 do
175 begin
176 Lexer:= Lexers[i];
177 if Lexer.LexerName=AName then
178 exit(Lexer);
179 end;
180 end;
181
182 procedure TATLiteLexers.LoadFromDir(const ADir: string);
183 var
184 Files: TStringList;
185 Lexer: TATLiteLexer;
186 i: integer;
187 begin
188 Files:= TStringList.Create;
189 try
190 FindAllFiles(Files, ADir, '*.json;*.cuda-litelexer', false);
191 Files.Sorted:= true;
192
193 for i:= 0 to Files.Count-1 do
194 begin
195 Lexer:= TATLiteLexer.Create(nil);
196 Lexer.OnGetStyleHash:= FOnGetStyleHash;
197 Lexer.OnApplyStyle:= FOnApplyStyle;
198 Lexer.LoadFromFile(Files[i]);
199 FList.Add(Lexer);
200 end;
201 finally
202 FreeAndNil(Files);
203 end;
204 end;
205
206 { TATLiteLexerRule }
207
208 constructor TATLiteLexerRule.Create(const AName, AStyle, ARegex: string; ACaseSens: boolean);
209 //
210 procedure InitRegex(var AObj: TecRegExpr);
211 begin
212 AObj:= TecRegExpr.Create;
213 AObj.Expression:= UTF8Decode(ARegex);
214 AObj.ModifierI:= not ACaseSens;
215 AObj.ModifierS:= false; //don't catch all text by .*
216 AObj.ModifierM:= true; //allow to work with ^$
217 AObj.ModifierX:= false; //don't ingore spaces
218 end;
219 //
220 begin
221 inherited Create;
222 Name:= AName;
223 Style:= AStyle;
224 InitRegex(RegexObj[false]);
225 InitRegex(RegexObj[true]);
226 end;
227
228 destructor TATLiteLexerRule.Destroy;
229 begin
230 FreeAndNil(RegexObj[false]);
231 FreeAndNil(RegexObj[true]);
232 inherited Destroy;
233 end;
234
235 { TATLiteLexer }
236
237 constructor TATLiteLexer.Create(AOnwer: TComponent);
238 begin
239 inherited;
240 FRules:= TFPList.Create;
241 end;
242
243 destructor TATLiteLexer.Destroy;
244 begin
245 Clear;
246 FreeAndNil(FRules);
247 inherited;
248 end;
249
TATLiteLexer.GetLexerNamenull250 function TATLiteLexer.GetLexerName: string;
251 begin
252 //it's important to return value with ' ^' suffix because suffix in checked in ATSynEdit
253 Result:= LexerName+' ^';
254 end;
255
256 procedure TATLiteLexer.Clear;
257 var
258 i: integer;
259 begin
260 LexerName:= '?';
261 CaseSens:= false;
262 ConsiderSpaces:= false;
263
264 for i:= RuleCount-1 downto 0 do
265 TObject(FRules[i]).Free;
266 FRules.Clear;
267 end;
268
IsFilenameMatchnull269 function TATLiteLexer.IsFilenameMatch(const AFilename: string): boolean;
270 begin
271 Result:= MatchesMaskList(AFilename, FileTypes, ';');
272 end;
273
RuleCountnull274 function TATLiteLexer.RuleCount: integer;
275 begin
276 Result:= FRules.Count;
277 end;
278
GetRulenull279 function TATLiteLexer.GetRule(AIndex: integer): TATLiteLexerRule;
280 begin
281 Result:= TATLiteLexerRule(FRules[AIndex]);
282 end;
283
284 procedure TATLiteLexer.LoadFromFile(const AFilename: string);
285 var
286 c: TJSONConfig;
287 keys: TStringList;
288 rule: TATLiteLexerRule;
289 s_name, s_regex, s_style: string;
290 i: integer;
291 begin
292 Clear;
293 if not FileExists(AFilename) then exit;
294
295 c:= TJSONConfig.Create(nil);
296 keys:= TStringList.Create;
297 try
298 try
299 c.Filename:= AFileName;
300 except
301 on E: Exception do
302 begin
303 ShowMessage('Cannot load JSON lexer file:'#10+ExtractFileName(AFilename)+#10#10+E.Message);
304 exit;
305 end;
306 end;
307
308 LexerName:= ChangeFileExt(ExtractFileName(AFilename), '');
309 CaseSens:= c.GetValue('/case_sens', false);
310 ConsiderSpaces:= c.GetValue('/consider_spaces', false);
311 FileTypes:= c.GetValue('/files', '');
312 CommentLine:= c.GetValue('/cmt_line', '');
313 CommentBlockBegin:= c.GetValue('/cmt_block_1', '');
314 CommentBlockEnd:= c.GetValue('/cmt_block_2', '');
315
316 c.EnumSubKeys('/rules', keys);
317 for i:= 0 to keys.Count-1 do
318 begin
319 s_name:= keys[i];
320 s_regex:= c.GetValue('/rules/'+s_name+'/regex', '');
321 s_style:= c.GetValue('/rules/'+s_name+'/style', '');
322 if (s_name='') or (s_regex='') or (s_style='') then Continue;
323
324 rule:= TATLiteLexerRule.Create(s_name, s_style, s_regex, CaseSens);
325 if Assigned(FOnGetStyleHash) then
326 rule.StyleHash:= FOnGetStyleHash(rule.Style);
327
328 FRules.Add(rule);
329 end;
330 finally
331 keys.Free;
332 c.Free;
333 end;
334 end;
335
Dumpnull336 function TATLiteLexer.Dump: string;
337 const
338 cBool: array[boolean] of string = ('false', 'true');
339 var
340 i: integer;
341 begin
342 Result:=
343 'name: '+LexerName+#10+
344 'case_sens: '+cBool[CaseSens]+#10+
345 'files: '+FileTypes+#10+
346 'rules:';
347 for i:= 0 to RuleCount-1 do
348 with Rules[i] do
349 Result:= Result+#10+Format('(name: "%s", re: "%s", st: "%s", st_n: %d)',
350 [Name, RegexObj[false].Expression, Style, StyleHash]);
351 end;
352
353
354 var
355 TempParts: TATLineParts;
356
357 procedure DoPartsDeleteBeginning(var AParts: TATLineParts; ADeleteCount: integer);
358 begin
359 FillChar(TempParts, SizeOf(TempParts), 0);
360 Move(AParts[ADeleteCount], TempParts, (High(AParts)+1-ADeleteCount)*SizeOf(TATLinePart));
361 Move(TempParts, AParts, SizeOf(TempParts));
362 end;
363
364
365 procedure TATLiteLexer.OnEditorCalcHilite(Sender: TObject;
366 var AParts: TATLineParts; ALineIndex, ACharIndex, ALineLen: integer;
367 var AColorAfterEol: TColor; AMainText: boolean);
368 var
369 Ed: TATSynEdit;
370 EdLine: UnicodeString;
371 ch: WideChar;
372 NParts, NPos, NLen, IndexRule: integer;
373 FixedOffset, FixedLen: integer;
374 Rule: TATLiteLexerRule;
375 bLastFound, bRuleFound: boolean;
376 begin
377 if Application.Terminated then exit;
378 Ed:= Sender as TATSynEdit;
379
380 EdLine:= Ed.Strings.Lines[ALineIndex];
381 NParts:= 0;
382 NPos:= 0;
383 bLastFound:= false;
384
385 repeat
386 Inc(NPos);
387 if NPos>Length(EdLine) then Break;
388 if NPos>ACharIndex+ALineLen then Break;
389 if NParts>=High(TATLineParts) then Break;
390 bRuleFound:= false;
391
392 ch:= EdLine[NPos];
393 if ConsiderSpaces or ((ch<>' ') and (ch<>#9)) then
394 for IndexRule:= 0 to RuleCount-1 do
395 begin
396 Rule:= Rules[IndexRule];
397 NLen:= Rule.RegexObj[AMainText].MatchLength(EdLine, NPos);
398 if NLen>0 then
399 begin
400 bRuleFound:= true;
401 Break;
402 end;
403 end;
404
405 if not bRuleFound then
406 begin
407 //add one char to part
408 if NPos+NLen>=ACharIndex then
409 begin
410 if (NParts=0) or bLastFound then
411 begin
412 Inc(NParts);
413 AParts[NParts-1].Offset:= NPos-1;
414 AParts[NParts-1].Len:= 1;
415 end
416 else
417 begin
418 Inc(AParts[NParts-1].Len);
419 end;
420 AParts[NParts-1].ColorBG:= clNone; //Random($fffff);
421 AParts[NParts-1].ColorFont:= Ed.Colors.TextFont;
422 end;
423 end
424 else
425 begin
426 //found rule, add NLen chars to part
427 if NPos+NLen>=ACharIndex then
428 begin
429 FixedOffset:= NPos-1;
430 FixedLen:= NLen;
431
432 Inc(NParts);
433 AParts[NParts-1].Offset:= FixedOffset;
434 AParts[NParts-1].Len:= FixedLen;
435 AParts[NParts-1].ColorBG:= clNone; //Random($fffff);
436 if Assigned(FOnApplyStyle) then
437 FOnApplyStyle(Rule.StyleHash, AParts[NParts-1]);
438 end;
439
440 Inc(NPos, NLen-1);
441 end;
442
443 bLastFound:= bRuleFound;
444 until false;
445
446 if ACharIndex>1 then
447 DoPartsCutFromOffset(AParts, ACharIndex-1);
448 end;
449
450 end.
451
452