unit PythonMemo;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, RichMemo, RegExpr, Graphics, LazUTF16;
type
TRule = record
RegExp: string;
Color: TColor;
Style: TFontstyles;
end;
{ TRichMemo }
TRichMemo = class (RichMemo.TRichMemo)
protected
procedure KeyDown(var Key: word; Shift: TShiftState); override;
procedure KeyUp(var Key: word; Shift: TShiftState); override;
procedure Click; override;
procedure DoEnter; override;
private
var Count: integer;
FRules: array[1..80] of TRule;
OldY: integer;
Toggle: Boolean;
OldBlank: boolean;
public
function RichXYtoX(X,Y:integer):integer;
procedure TouchLine(n: integer);
const
LKEYWORDS : TStringArray =
('and', 'assert', 'break', 'class', 'continue', 'def',
'del', 'elif', 'else', 'except', 'exec', 'finally',
'for', 'from', 'global', 'if', 'import', 'in',
'is', 'lambda', 'not', 'or', 'pass', 'print',
'raise', 'return', 'try', 'while', 'yield',
'None', 'True', 'False');
LSYMBOLS : TStringArray =
('=',
'==', '!=', '<', '<=', '>', '>=',
'\+', '-', '\*', '/', '\%',
'\+=', '-=', '\*=', '/=', '\%=',
'\^', '\|', '\&', '\~', '>>', '<<',
'\{', '\}', '\[', '\]', '\(', '\)',
'\.', ',', ';', ':', '\\', '!', '@', '&');
public
constructor Create(AOwner: TComponent); override;
end;
implementation
// Calling this RichXYtoX to remind myself that it is NOT compatible with
// the regular TMemo, which should have ... (Lines[i])+2;
function TRichMemo.RichXYtoX(X,Y:integer): integer;
var i:integer;
L:integer;
begin
L:=utf16length(Text);
RichXYtoX:=0;
for i:=0 to Y-1 do
begin
RichXYtoX:=RichXYtoX+utf16length(Lines[i]);
if (RichXYtoX < L) and (Text[RichXYtoX+1]=#13) then
begin
RichXYtoX:=RichXYtoX + 1;
end;
end;
RichXYtoX:=RichXYtoX+X;
end;
function firstnonspace(s:string):integer;
begin
// To be more accurate, it returns the number of leading spaces plus one. So the empty string returns 1.
firstnonspace:=1; while (s<>'') and (s[firstnonspace] = ' ') and (firstnonspace<=length(s)) do firstnonspace:=firstnonspace+1;
end;
constructor TRichMemo.Create(AOwner: TComponent);
procedure add(s: string; c: TColor; fs: TFontStyles);
begin
Count:=Count+1;
FRules[Count].RegExp:=s;
FRules[Count].Color:=c;
FRules[Count].Style:=fs;
end;
var i: integer;
begin
inherited;
OldY:=0;
Count:=0;
OldBlank:=false;
Toggle:=false;
for i:=0 to length(LKEYWORDS)-1 do
add('\b'+LKEYWORDS[i]+'\b', clBlack, [fsBold]);
for i:=0 to length(LSYMBOLS)-1 do
add(LSYMBOLS[i], clRed, []);
add('"[^"\\]*(\\.[^"\\]*)*"', clBlue, []);
add('''[^''\\]*(\\.[^''\\]*)*''', clBlue, []);
add('\b[+-]?[0-9]+[lL]?\b', clBlue, []);
add('\b[+-]?0[xX][0-9A-Fa-f]+[lL]?\b', clBlue, []);
add('\b[+-]?[0-9]+(?:\.[0-9]+)?(?:[eE][+-]?[0-9]+)?\b', clBlue, []);
add('#[^\n]*', clGreen, [fsItalic]);
end;
procedure TRichMemo.TouchLine(n: integer);
var RE: TregExpr;
TF: TFont;
off: integer;
i: integer;
begin
if Lines[n]='' then Exit;
off:=RichXYtoX(0,n);
TF:=TFont.Create();
TF.Name:=Font.Name; TF.Size:=Font.Size; TF.Color:=clBlack; TF.Style:=[];
SetTextAttributes(off,utf16length(Lines[n])+1,TF); // Make everything plain black including the newlines (hence the +1).
RE:=TRegExpr.Create;
for i:=1 to Count do
begin
RE.Expression:=FRules[i].RegExp;
RE.InputString:=self.Lines[n];
if RE.Exec then
repeat
TF.Color:=FRules[i].Color;
TF.Style:=FRules[i].Style;
self.SetTextAttributes(off+RE.MatchPos[0]-1,RE.MatchLen[0],TF)
until not RE.ExecNext;
end;
RE.Free;
TF.Free;
end;
procedure TRichMemo.KeyUp(var Key: Word; Shift: TShiftstate);
var i,j: integer;
x,y: integer;
tn: integer;
begin
x:=self.CaretPos.X;
y:=self.CaretPos.Y;
//We handle the enter, tab, and backspace keys.
if (Key=13) and (y>0) and (Lines[y-1]<>'') then // enter
begin
if not Toggle then
begin
j:=firstnonspace(Lines[y-1]);
if Lines[y-1][length(Lines[y-1])] = ':' then j:=j+4;
Lines[y]:=StringOfChar(' ',j-1)+Lines[y];
CaretPos := TPoint.Create(j-1,y);
end;
end;
if Key=9 then // tab
begin
if not Toggle then
begin
Lines[y]:=copy(Lines[y],1,x)+' '+copy(Lines[y],x+1,length(Lines[y])-x);
CaretPos := TPoint.Create(x+4,y);
key:=0;
end;
end;
if (Key=8) and (x>0) and (copy(Lines[y],1,x) = stringofchar(' ',x)) and OldBlank then // backspace
begin
if not Toggle then
begin
tn := 4*((x-1) div 4); // Because this is how deleting whitespace should work, change the code or sue me.
Lines[y]:=stringofchar(' ',tn)+copy(Lines[y],x+1,length(Lines[y])-x);
CaretPos := TPoint.Create(tn,y);
key:=0;
end;
end;
// Then we do the syntax highlighting.
x:=self.CaretPos.X;
y:=self.CaretPos.Y;
if y<=OldY then
TouchLine(y)
else
for i:=OldY to y do
TouchLine(i);
inherited;
end;
procedure TRichMemo.KeyDown(var Key: Word; Shift: TShiftstate);
var x,y: integer;
begin
x:=self.CaretPos.X;
y:=self.CaretPos.Y;
OldBlank := ((copy(Lines[y],1,x) = stringofchar(' ',x)));
inherited;
Toggle:=true;
if key = 9 then key:=0;
KeyUp(Key, Shift);
Toggle:=false;
end;
procedure TRichMemo.Click;
begin
OldY:=CaretPos.Y;
inherited;
end;
procedure TRichMemo.DoEnter;
begin
Toggle:=true;
OldY:=CaretPos.Y;
inherited;
end;
end.