unit LazSynTextArea; {$mode objfpc}{$H+} interface uses Classes, SysUtils, Graphics, Controls, LCLType, LCLIntf, LCLProc, SynEditTypes, SynEditMiscProcs, SynEditMiscClasses, LazSynEditText, SynEditMarkup, SynEditHighlighter, SynTextDrawer; type { TLazSynTextArea } TLazSynTextArea = class(TLazSynSurface) private FCharsInWindow: Integer; FCharWidth: integer; FLinesInWindow: Integer; FTextHeight: integer; FCanvas: TCanvas; FTextDrawer: TheTextDrawer; FTheLinesView: TSynEditStrings; FHighlighter: TSynCustomHighlighter; FMarkupManager: TSynEditMarkupManager; FPaintLineColor, FPaintLineColor2: TSynSelectedColor; FForegroundColor: TColor; FBackgroundColor: TColor; FRightEdgeColor: TColor; FTextBounds: TRect; FPadding: array [TLazSynBorderSide] of Integer; FExtraCharSpacing: integer; FExtraLineSpacing: integer; FVisibleSpecialChars: TSynVisibleSpecialChars; FRightEdgeColumn: integer; FRightEdgeVisible: boolean; FTopLine: TLinePos; FLeftChar: Integer; function GetPadding(Side: TLazSynBorderSide): integer; procedure SetExtraCharSpacing(AValue: integer); procedure SetExtraLineSpacing(AValue: integer); procedure SetLeftChar(AValue: Integer); procedure SetPadding(Side: TLazSynBorderSide; AValue: integer); procedure SetTopLine(AValue: TLinePos); procedure DoDrawerFontChanged(Sender: TObject); protected procedure BoundsChanged; override; procedure DoPaint(ACanvas: TCanvas; AClip: TRect); override; procedure PaintTextLines(AClip: TRect; FirstLine, LastLine, FirstCol, LastCol: integer); virtual; property Canvas: TCanvas read FCanvas; public constructor Create(AOwner: TWinControl; ATextDrawer: TheTextDrawer); destructor Destroy; override; procedure Assign(Src: TLazSynSurface); override; procedure InvalidateLines(FirstTextLine, LastTextLine: TLineIdx); override; function ScreenColumnToXValue(Col: integer): integer; // map screen column to screen pixel function RowColumnToPixels(const RowCol: TPoint): TPoint; function PixelsToRowColumn(Pixels: TPoint; aFlags: TSynCoordinateMappingFlags): TPoint; // ignores scmLimitToLines procedure FontChanged; // Settings controlled by SynEdit property Padding[Side: TLazSynBorderSide]: integer read GetPadding write SetPadding; property ForegroundColor: TColor read FForegroundColor write FForegroundColor; property BackgroundColor: TColor read FBackgroundColor write FBackgroundColor; property ExtraCharSpacing: integer read FExtraCharSpacing write SetExtraCharSpacing; property ExtraLineSpacing: integer read FExtraLineSpacing write SetExtraLineSpacing; property VisibleSpecialChars: TSynVisibleSpecialChars read FVisibleSpecialChars write FVisibleSpecialChars; property RightEdgeColumn: integer read FRightEdgeColumn write FRightEdgeColumn; property RightEdgeVisible: boolean read FRightEdgeVisible write FRightEdgeVisible; property RightEdgeColor: TColor read FRightEdgeColor write FRightEdgeColor; property TopLine: TLinePos read FTopLine write SetTopLine; // TopView property LeftChar: Integer read FLeftChar write SetLeftChar; property TheLinesView: TSynEditStrings read FTheLinesView write FTheLinesView; property Highlighter: TSynCustomHighlighter read FHighlighter write FHighlighter; property MarkupManager: TSynEditMarkupManager read FMarkupManager write FMarkupManager; property TextDrawer: TheTextDrawer read FTextDrawer; public property TextBounds: TRect read FTextBounds; property LineHeight: integer read FTextHeight; property CharWidth: integer read FCharWidth; property LinesInWindow: Integer read FLinesInWindow; property CharsInWindow: Integer read FCharsInWindow; end; { TLazSynSurfaceManager } TLazSynSurfaceManager = class(TLazSynSurface) private FLeftGutterArea: TLazSynSurface; FLeftGutterWidth: integer; FRightGutterArea: TLazSynSurface; FRightGutterWidth: integer; FTextArea: TLazSynTextArea; procedure SetLeftGutterArea(AValue: TLazSynSurface); procedure SetLeftGutterWidth(AValue: integer); procedure SetRightGutterArea(AValue: TLazSynSurface); procedure SetRightGutterWidth(AValue: integer); procedure SetTextArea(AValue: TLazSynTextArea); protected function GetLeftGutterArea: TLazSynSurface; virtual; function GetRightGutterArea: TLazSynSurface; virtual; function GetTextArea: TLazSynTextArea; virtual; protected procedure SetBackgroundColor(AValue: TColor); virtual; procedure SetExtraCharSpacing(AValue: integer); virtual; procedure SetExtraLineSpacing(AValue: integer); virtual; procedure SetForegroundColor(AValue: TColor); virtual; procedure SetPadding(Side: TLazSynBorderSide; AValue: integer); virtual; procedure SetRightEdgeColor(AValue: TColor); virtual; procedure SetRightEdgeColumn(AValue: integer); virtual; procedure SetRightEdgeVisible(AValue: boolean); virtual; procedure SetVisibleSpecialChars(AValue: TSynVisibleSpecialChars); virtual; procedure SetHighlighter(AValue: TSynCustomHighlighter); virtual; protected procedure DoPaint(ACanvas: TCanvas; AClip: TRect); override; procedure DoDisplayViewChanged; override; procedure BoundsChanged; override; public constructor Create(AOwner: TWinControl); procedure InvalidateLines(FirstTextLine, LastTextLine: TLineIdx); override; procedure InvalidateTextLines(FirstTextLine, LastTextLine: TLineIdx); virtual; procedure InvalidateGutterLines(FirstTextLine, LastTextLine: TLineIdx); virtual; property TextArea: TLazSynTextArea read GetTextArea write SetTextArea; property LeftGutterArea: TLazSynSurface read GetLeftGutterArea write SetLeftGutterArea; property RightGutterArea: TLazSynSurface read GetRightGutterArea write SetRightGutterArea; property LeftGutterWidth: integer read FLeftGutterWidth write SetLeftGutterWidth; property RightGutterWidth: integer read FRightGutterWidth write SetRightGutterWidth; public // Settings forwarded to textarea property Padding[Side: TLazSynBorderSide]: integer write SetPadding; property ForegroundColor: TColor write SetForegroundColor; property BackgroundColor: TColor write SetBackgroundColor; property ExtraCharSpacing: integer write SetExtraCharSpacing; property ExtraLineSpacing: integer write SetExtraLineSpacing; property VisibleSpecialChars: TSynVisibleSpecialChars write SetVisibleSpecialChars; property RightEdgeColumn: integer write SetRightEdgeColumn; property RightEdgeVisible: boolean write SetRightEdgeVisible; property RightEdgeColor: TColor write SetRightEdgeColor; property Highlighter: TSynCustomHighlighter write SetHighlighter; end; implementation { TLazSynSurfaceManager } procedure TLazSynSurfaceManager.SetLeftGutterWidth(AValue: integer); begin if FLeftGutterWidth = AValue then Exit; FLeftGutterWidth := AValue; BoundsChanged; end; procedure TLazSynSurfaceManager.SetPadding(Side: TLazSynBorderSide; AValue: integer); begin FTextArea.Padding[Side] := AValue; end; procedure TLazSynSurfaceManager.SetRightEdgeColor(AValue: TColor); begin FTextArea.RightEdgeColor := AValue; end; procedure TLazSynSurfaceManager.SetRightEdgeColumn(AValue: integer); begin FTextArea.RightEdgeColumn := AValue; end; procedure TLazSynSurfaceManager.SetRightEdgeVisible(AValue: boolean); begin FTextArea.RightEdgeVisible := AValue; end; procedure TLazSynSurfaceManager.SetLeftGutterArea(AValue: TLazSynSurface); begin if FLeftGutterArea = AValue then Exit; FLeftGutterArea := AValue; FLeftGutterArea.DisplayView := DisplayView; end; function TLazSynSurfaceManager.GetLeftGutterArea: TLazSynSurface; begin Result := FLeftGutterArea; end; function TLazSynSurfaceManager.GetRightGutterArea: TLazSynSurface; begin Result := FRightGutterArea; end; function TLazSynSurfaceManager.GetTextArea: TLazSynTextArea; begin Result := FTextArea; end; procedure TLazSynSurfaceManager.SetBackgroundColor(AValue: TColor); begin FTextArea.BackgroundColor := AValue; end; procedure TLazSynSurfaceManager.SetExtraCharSpacing(AValue: integer); begin FTextArea.ExtraCharSpacing := AValue; end; procedure TLazSynSurfaceManager.SetExtraLineSpacing(AValue: integer); begin FTextArea.ExtraLineSpacing := AValue; end; procedure TLazSynSurfaceManager.SetForegroundColor(AValue: TColor); begin FTextArea.ForegroundColor := AValue; end; procedure TLazSynSurfaceManager.SetRightGutterArea(AValue: TLazSynSurface); begin if FRightGutterArea = AValue then Exit; FRightGutterArea := AValue; FRightGutterArea.DisplayView := DisplayView; end; procedure TLazSynSurfaceManager.SetRightGutterWidth(AValue: integer); begin if FRightGutterWidth = AValue then Exit; FRightGutterWidth := AValue; BoundsChanged; end; procedure TLazSynSurfaceManager.SetTextArea(AValue: TLazSynTextArea); begin if FTextArea = AValue then Exit; FTextArea := AValue; FTextArea.DisplayView := DisplayView; end; procedure TLazSynSurfaceManager.SetVisibleSpecialChars(AValue: TSynVisibleSpecialChars); begin FTextArea.VisibleSpecialChars := AValue; end; procedure TLazSynSurfaceManager.SetHighlighter(AValue: TSynCustomHighlighter); begin FTextArea.Highlighter := AValue; end; procedure TLazSynSurfaceManager.DoPaint(ACanvas: TCanvas; AClip: TRect); begin FLeftGutterArea.Paint(ACanvas, AClip); FTextArea.Paint(ACanvas, AClip); FRightGutterArea.Paint(ACanvas, AClip); end; procedure TLazSynSurfaceManager.DoDisplayViewChanged; begin FLeftGutterArea.DisplayView := DisplayView; FRightGutterArea.DisplayView := DisplayView; FTextArea.DisplayView := DisplayView; end; procedure TLazSynSurfaceManager.BoundsChanged; var l, r: Integer; begin r := Max(Left, Right - RightGutterWidth); l := Min(r, Left + LeftGutterWidth); FLeftGutterArea.SetBounds(Top, Left, Bottom, l); FTextArea.SetBounds(Top, l, Bottom, r); FRightGutterArea.SetBounds(Top, r, Bottom, Right); end; constructor TLazSynSurfaceManager.Create(AOwner: TWinControl); begin inherited Create(AOwner); FLeftGutterWidth := 0; FRightGutterWidth := 0; end; procedure TLazSynSurfaceManager.InvalidateLines(FirstTextLine, LastTextLine: TLineIdx); var rcInval: TRect; begin rcInval := Bounds; if (FirstTextLine >= 0) then rcInval.Top := Max(TextArea.TextBounds.Top, TextArea.TextBounds.Top + (DisplayView.TextToViewIndex(FirstTextLine).Top - TextArea.TopLine + 1) * TextArea.LineHeight); if (LastTextLine >= 0) then rcInval.Bottom := Min(TextArea.TextBounds.Bottom, TextArea.TextBounds.Top + (DisplayView.TextToViewIndex(LastTextLine).Bottom - TextArea.TopLine + 2) * TextArea.LineHeight); {$IFDEF VerboseSynEditInvalidate} DebugLn(['TCustomSynEdit.InvalidateGutterLines ',DbgSName(self), ' FirstLine=',FirstTextLine, ' LastLine=',LastTextLine, ' rect=',dbgs(rcInval)]); {$ENDIF} if (rcInval.Top < rcInval.Bottom) and (rcInval.Left < rcInval.Right) then InvalidateRect(Handle, @rcInval, FALSE); end; procedure TLazSynSurfaceManager.InvalidateTextLines(FirstTextLine, LastTextLine: TLineIdx); begin FTextArea.InvalidateLines(FirstTextLine, LastTextLine); end; procedure TLazSynSurfaceManager.InvalidateGutterLines(FirstTextLine, LastTextLine: TLineIdx); begin FLeftGutterArea.InvalidateLines(FirstTextLine, LastTextLine); FRightGutterArea.InvalidateLines(FirstTextLine, LastTextLine); end; { TLazSynTextArea } function TLazSynTextArea.GetPadding(Side: TLazSynBorderSide): integer; begin Result := FPadding[Side]; end; procedure TLazSynTextArea.SetExtraCharSpacing(AValue: integer); begin if FExtraCharSpacing = AValue then Exit; FExtraCharSpacing := AValue; FontChanged; end; procedure TLazSynTextArea.SetExtraLineSpacing(AValue: integer); begin if FExtraLineSpacing = AValue then Exit; FExtraLineSpacing := AValue; FTextHeight := FTextDrawer.CharHeight + FExtraLineSpacing; FontChanged; end; procedure TLazSynTextArea.SetLeftChar(AValue: Integer); begin if FLeftChar = AValue then Exit; FLeftChar := AValue; end; procedure TLazSynTextArea.SetPadding(Side: TLazSynBorderSide; AValue: integer); begin FPadding[Side] := AValue; case Side of bsLeft: FTextBounds.Left := Left + FPadding[bsLeft]; bsTop: FTextBounds.Top := Top + FPadding[bsTop]; bsRight: FTextBounds.Right := Right - FPadding[bsRight]; bsBottom: FTextBounds.Bottom := Bottom - FPadding[bsBottom]; end; FontChanged; end; procedure TLazSynTextArea.SetTopLine(AValue: TLinePos); begin if AValue < 1 then AValue := 1; if FTopLine = AValue then Exit; FTopLine := AValue; end; procedure TLazSynTextArea.DoDrawerFontChanged(Sender: TObject); begin FontChanged; end; procedure TLazSynTextArea.BoundsChanged; begin FTextBounds.Left := Left + FPadding[bsLeft]; FTextBounds.Top := Top + FPadding[bsTop]; FTextBounds.Right := Right - FPadding[bsRight]; FTextBounds.Bottom := Bottom - FPadding[bsBottom]; FontChanged; end; function TLazSynTextArea.ScreenColumnToXValue(Col: integer): integer; begin Result := FTextBounds.Left + (Col - LeftChar) * fCharWidth; end; function TLazSynTextArea.RowColumnToPixels(const RowCol: TPoint): TPoint; begin // Inludes LeftChar, but not Topline Result.X := FTextBounds.Left + (RowCol.X - LeftChar) * CharWidth; Result.Y := FTextBounds.Top + RowCol.Y * LineHeight; end; function TLazSynTextArea.PixelsToRowColumn(Pixels: TPoint; aFlags: TSynCoordinateMappingFlags): TPoint; begin // Inludes LeftChar, but not Topline Result.X := (Pixels.X - FTextBounds.Left + (CharWidth div 2) // nearest side of char ) div CharWidth + LeftChar; Result.Y := (Pixels.Y - FTextBounds.Top) div LineHeight; if (not(scmIncludePartVisible in aFlags)) and (Result.Y >= LinesInWindow) then begin // don't return a partially visible last line Result.Y := LinesInWindow - 1; end; if Result.X < 0 then Result.X := 0; if Result.Y < 0 then Result.Y := 0; end; constructor TLazSynTextArea.Create(AOwner: TWinControl; ATextDrawer: TheTextDrawer); var i: TLazSynBorderSide; begin inherited Create(AOwner); FTextDrawer := ATextDrawer; FTextDrawer.RegisterOnFontChangeHandler(@DoDrawerFontChanged); FPaintLineColor := TSynSelectedColor.Create; FPaintLineColor2 := TSynSelectedColor.Create; for i := low(TLazSynBorderSide) to high(TLazSynBorderSide) do FPadding[i] := 0; FTopLine := 1; FLeftChar := 1; FRightEdgeColumn := 80; FRightEdgeVisible := True; FRightEdgeColor := clSilver; FontChanged; end; destructor TLazSynTextArea.Destroy; begin FTextDrawer.UnRegisterOnFontChangeHandler(@DoDrawerFontChanged); FreeAndNil(FPaintLineColor); FreeAndNil(FPaintLineColor2); inherited Destroy; end; procedure TLazSynTextArea.Assign(Src: TLazSynSurface); var i: TLazSynBorderSide; begin inherited Assign(Src); FTextDrawer := TLazSynTextArea(Src).FTextDrawer; FTheLinesView := TLazSynTextArea(Src).FTheLinesView; DisplayView := TLazSynTextArea(Src).DisplayView; FHighlighter := TLazSynTextArea(Src).FHighlighter; FMarkupManager := TLazSynTextArea(Src).FMarkupManager; FForegroundColor := TLazSynTextArea(Src).FForegroundColor; FBackgroundColor := TLazSynTextArea(Src).FBackgroundColor; FRightEdgeColor := TLazSynTextArea(Src).FRightEdgeColor; FExtraCharSpacing := TLazSynTextArea(Src).FExtraCharSpacing; FExtraLineSpacing := TLazSynTextArea(Src).FExtraLineSpacing; FVisibleSpecialChars := TLazSynTextArea(Src).FVisibleSpecialChars; FRightEdgeColumn := TLazSynTextArea(Src).FRightEdgeColumn; FRightEdgeVisible := TLazSynTextArea(Src).FRightEdgeVisible; for i := low(TLazSynBorderSide) to high(TLazSynBorderSide) do FPadding[i] := TLazSynTextArea(Src).FPadding[i]; FTopLine := TLazSynTextArea(Src).FTopLine; FLeftChar := TLazSynTextArea(Src).FLeftChar; BoundsChanged; end; procedure TLazSynTextArea.InvalidateLines(FirstTextLine, LastTextLine: TLineIdx); var rcInval: TRect; begin rcInval := Bounds; if (FirstTextLine >= 0) then rcInval.Top := Max(TextBounds.Top, TextBounds.Top + (DisplayView.TextToViewIndex(FirstTextLine).Top - TopLine + 1) * LineHeight); if (LastTextLine >= 0) then rcInval.Bottom := Min(TextBounds.Bottom, TextBounds.Top + (DisplayView.TextToViewIndex(LastTextLine).Bottom - TopLine + 2) * LineHeight); {$IFDEF VerboseSynEditInvalidate} DebugLn(['TCustomSynEdit.InvalidateTextLines ',DbgSName(self), ' FirstLine=',FirstTextLine, ' LastLine=',LastTextLine, ' rect=',dbgs(rcInval)]); {$ENDIF} if (rcInval.Top < rcInval.Bottom) and (rcInval.Left < rcInval.Right) then InvalidateRect(Handle, @rcInval, FALSE); end; procedure TLazSynTextArea.FontChanged; begin // ToDo: wait for handle creation // Report FLinesInWindow=-1 if no handle FCharWidth := FTextDrawer.CharWidth; // includes extra FTextHeight := FTextDrawer.CharHeight + FExtraLineSpacing; FCharsInWindow := 0; FLinesInWindow := 0; if FCharWidth > 0 then FCharsInWindow := Max(0, (FTextBounds.Right - FTextBounds.Left) div FCharWidth); if FTextHeight > 0 then FLinesInWindow := Max(0, (FTextBounds.Bottom - FTextBounds.Top) div FTextHeight); end; procedure TLazSynTextArea.DoPaint(ACanvas: TCanvas; AClip: TRect); var PadRect, PadRect2: TRect; ScreenRow1, ScreenRow2, TextColumn1, TextColumn2: integer; dc: HDC; begin // paint padding FCanvas := ACanvas; dc := ACanvas.Handle; SetBkColor(dc, ColorToRGB(BackgroundColor)); if (AClip.Top < FTextBounds.Top) then begin PadRect2 := Bounds; PadRect2.Bottom := FTextBounds.Top; IntersectRect(PadRect{%H-}, AClip, PadRect2); InternalFillRect(dc, PadRect); end; if (AClip.Bottom > FTextBounds.Bottom) then begin PadRect2 := Bounds; PadRect2.Top := FTextBounds.Bottom; IntersectRect(PadRect, AClip, PadRect2); InternalFillRect(dc, PadRect); end; if (AClip.Left < FTextBounds.Left) then begin PadRect2 := Bounds; PadRect2.Right := FTextBounds.Left; IntersectRect(PadRect, AClip, PadRect2); InternalFillRect(dc, PadRect); end; if (AClip.Right > FTextBounds.Right) then begin PadRect2 := Bounds; PadRect2.Left := FTextBounds.Right; IntersectRect(PadRect, AClip, PadRect2); InternalFillRect(dc, PadRect); end; if (AClip.Left >= FTextBounds.Right) or (AClip.Right <= FTextBounds.Left) or (AClip.Top >= FTextBounds.Bottom) or (AClip.Bottom <= FTextBounds.Top) then exit; TextColumn1 := LeftChar; if (AClip.Left > FTextBounds.Left) then Inc(TextColumn1, (AClip.Left - FTextBounds.Left) div CharWidth); TextColumn2 := LeftChar + ( Min(AClip.Right, FTextBounds.Right) - FTextBounds.Left + CharWidth - 1) div CharWidth; // lines ScreenRow1 := Max((AClip.Top - FTextBounds.Top) div fTextHeight, 0); ScreenRow2 := Min((AClip.Bottom-1 - FTextBounds.Top) div fTextHeight, LinesInWindow + 1); AClip.Left := Max(AClip.Left, FTextBounds.Left); // Todo: This is also checked in paintLines (together with right side) AClip.Right := Min(AClip.Right, FTextBounds.Right); //AClip.Top := Max(AClip.Top, FTextBounds.Top); //AClip.Bottom := Min(AClip.Bottom, FTextBounds.Bottom); SetBkMode(dc, TRANSPARENT); PaintTextLines(AClip, ScreenRow1, ScreenRow2, TextColumn1, TextColumn2); FCanvas := nil; end; procedure TLazSynTextArea.PaintTextLines(AClip: TRect; FirstLine, LastLine, FirstCol, LastCol: integer); // FirstLine, LastLine are based 0 // FirstCol, LastCol are screen based 1 without scrolling (physical position). // i.e. the real screen position is fTextOffset+Pred(FirstCol)*CharWidth var bDoRightEdge: boolean; // right edge nRightEdge: integer; colEditorBG: TColor; // painting the background and the text rcLine, rcToken: TRect; EraseLeft, DrawLeft: Integer; // LeftSide for EraseBackground, Text CurLine: integer; // Screen-line index for the loop CurTextIndex: Integer; // Current Index in text CurPhysPos, CurLogIndex : Integer; // Physical Start Position of next token in current Line ForceEto: Boolean; TokenAccu: record Len, MaxLen: integer; PhysicalStartPos, PhysicalEndPos: integer; p: PChar; FG, BG: TColor; Style: TFontStyles; FrameColor: array[TLazSynBorderSide] of TColor; FrameStyle: array[TLazSynBorderSide] of TSynLineStyle; end; dc: HDC; ExpandedPaintToken: string; // used to create the string sent to TextDrawer CharWidths: TPhysicalCharWidths; { local procedures } procedure SetTokenAccuLength; begin ReAllocMem(TokenAccu.p,TokenAccu.MaxLen+1); TokenAccu.p[TokenAccu.MaxLen]:=#0; end; function ExpandSpecialChars(var p: PChar; var Count: integer; PhysicalStartPos: integer): Integer; // if there are no tabs or special chars: keep p and Count untouched // if there are special chars: copy p into ExpandedPaintToken buffer, // convert tabs to spaces, and return the buffer // Return DisplayCell-Count in Buffer var i: integer; LengthNeeded: Integer; DestPos: Integer; SrcPos: Integer; Dest: PChar; c: Char; CharLen: Integer; Special, SpecialTab1, SpecialTab2, SpecialSpace, HasTabs: boolean; Fill: Integer; begin LengthNeeded := 0; Result := 0; if CurLogIndex >= length(CharWidths) then begin // past eol (e.g. fold marker). No special handling. No support for double width chars // count utf8 chars for i := 0 to Count -1 do if p[i] <= #$7f then inc(Result); exit; end; HasTabs := False; SrcPos:=0; for i := CurLogIndex to CurLogIndex + Count -1 do begin Result := Result + CharWidths[i]; if CharWidths[i] > 1 then LengthNeeded := LengthNeeded + CharWidths[i] - 1; if p[SrcPos] = #9 then HasTabs := True; inc(SrcPos); end; Special := VisibleSpecialChars <> []; if (not Special) and (LengthNeeded=0) and (not HasTabs) and (FindInvalidUTF8Character(p,Count)<0) then exit; SpecialTab1 := Special and (vscTabAtFirst in FVisibleSpecialChars); SpecialTab2 := Special and (vscTabAtLast in FVisibleSpecialChars); SpecialSpace := Special and (vscSpace in FVisibleSpecialChars); LengthNeeded := LengthNeeded + Count; if Special then LengthNeeded:=LengthNeeded*2; if length(ExpandedPaintToken)> Dest[DestPos-1] := #194; Dest[DestPos] := #187; inc(DestPos, 1); end; inc(SrcPos); end else begin // could be UTF8 char if c in [#128..#255] then CharLen := UTF8CharacterStrictLength(@p[SrcPos]) else CharLen := 1; if CharLen=0 then begin // invalid character Dest[DestPos]:='?'; inc(DestPos); inc(SrcPos); end else begin // normal UTF-8 character for i:=1 to CharLen do begin Dest[DestPos]:=p[SrcPos]; inc(DestPos); inc(SrcPos); end; if (c = #32) and SpecialSpace then begin // #194#183 looks like . Dest[DestPos-1] := #194; Dest[DestPos] := #183; inc(DestPos); end; for i := 1 to Fill do begin Dest[DestPos]:= ' '; inc(DestPos); end; end; // ToDo: pass the eto with to fTextDrawer, instead of filling with spaces if Fill > 0 then ForceEto := True; end; end; end else begin // non UTF-8 while SrcPos 0 then ForceEto := True; end; inc(DestPos); inc(SrcPos); for i := 1 to Fill do begin Dest[DestPos]:= ' '; inc(DestPos); end; end; end; p:=PChar(Pointer(ExpandedPaintToken)); Count:=DestPos; //debugln('ExpandSpecialChars Token with Tabs: "',DbgStr(copy(ExpandedPaintToken,1,Count)),'"'); end; const ETOOptions = ETO_OPAQUE; // Note: clipping is slow and not needed procedure PaintToken(Token: PChar; TokenLen, FirstPhysical: integer); // FirstPhysical is the physical (screen without scrolling) // column of the first character var nX: integer; tok: TRect; begin {debugln('PaintToken A TokenLen=',dbgs(TokenLen), ' FirstPhysical=',dbgs(FirstPhysical), ' Tok="'+copy(Token, 1, TokenLen),'"', ' rcToken='+dbgs(rcToken.Left)+'-'+dbgs(rcToken.Right));} if (rcToken.Right <= rcToken.Left) then exit; // Draw the right edge under the text if necessary nX := ScreenColumnToXValue(FirstPhysical); // == rcToken.Left if ForceEto then fTextDrawer.ForceNextTokenWithEto; if bDoRightEdge and (nRightEdge=rcToken.Left) then begin // draw background (use rcToken, so we do not delete the divider-draw-line) if rcToken.Left < nRightEdge then begin tok := rcToken; tok.Right := nRightEdge; InternalFillRect(dc, tok); end; if rcToken.Right > nRightEdge then begin tok := rcToken; tok.Left := nRightEdge; tok.Bottom := rcLine.Bottom; InternalFillRect(dc, tok); end; // draw edge (use rcLine / rcToken may be reduced) LCLIntf.MoveToEx(dc, nRightEdge, rcLine.Top, nil); LCLIntf.LineTo(dc, nRightEdge, rcLine.Bottom + 1); // draw text fTextDrawer.ExtTextOut(nX, rcToken.Top, ETOOptions-ETO_OPAQUE, rcToken, Token, TokenLen, rcLine.Bottom); end else begin // draw text with background //debugln('PaintToken nX=',dbgs(nX),' Token=',dbgstr(copy(Token,1, TokenLen)),' rcToken=',dbgs(rcToken)); tok := rcToken; if rcToken.Right > nRightEdge + 1 then tok.Bottom := rcLine.Bottom; fTextDrawer.ExtTextOut(nX, rcToken.Top, ETOOptions, tok, Token, TokenLen, rcLine.Bottom); end; rcToken.Left := rcToken.Right; end; procedure PaintHighlightToken(bFillToEOL: boolean); var Spaces: String = ' '; nX1, eolx: integer; NextPos, CurPos: Integer; MarkupInfo: TSynSelectedColor; tok: TRect; Attr: TSynHighlighterAttributes; s: TLazSynBorderSide; HasFrame: Boolean; begin {debugln('PaintHighlightToken A TokenAccu: Len=',dbgs(TokenAccu.Len), ' PhysicalStartPos=',dbgs(TokenAccu.PhysicalStartPos), ' PhysicalEndPos=',dbgs(TokenAccu.PhysicalEndPos), ' "',copy(TokenAccu.p,1,TokenAccu.Len),'"');} // Any token chars accumulated? if (TokenAccu.Len > 0) then begin // Initialize the colors and the font style. with fTextDrawer do begin SetBackColor(TokenAccu.BG); SetForeColor(TokenAccu.FG); SetStyle(TokenAccu.Style); for s := low(TLazSynBorderSide) to high(TLazSynBorderSide) do begin FrameColor[s] := TokenAccu.FrameColor[s]; FrameStyle[s] := TokenAccu.FrameStyle[s]; end; end; // Paint the chars rcToken.Right := ScreenColumnToXValue(TokenAccu.PhysicalEndPos+1); if rcToken.Right > AClip.Right then begin rcToken.Right := AClip.Right; fTextDrawer.FrameColor[bsRight] := clNone; // right side of char is not painted end; with TokenAccu do PaintToken(p, Len, PhysicalStartPos); end; // Fill the background to the end of this line if necessary. if bFillToEOL and (rcToken.Left < rcLine.Right) then begin eolx := rcToken.Left; // remeber end of actual line, so we can decide to draw the right edge NextPos := Min(LastCol, TokenAccu.PhysicalEndPos+1); MarkupInfo := TSynSelectedColor.Create; if Assigned(fHighlighter) then Attr := fHighlighter.GetEndOfLineAttribute else Attr := nil; repeat CurPos := NextPos; NextPos := fMarkupManager.GetNextMarkupColAfterRowCol(CurTextIndex+1, NextPos); if Assigned(Attr) then MarkupInfo.Assign(Attr) else MarkupInfo.Clear; MarkupInfo.MergeFinalStyle := True; MarkupInfo.StyleMask := []; if MarkupInfo.Background = clNone then MarkupInfo.Background := colEditorBG; if MarkupInfo.Foreground = clNone then MarkupInfo.Foreground := ForegroundColor; MarkupInfo.StartX := CurPos; MarkupInfo.EndX := NextPos; fMarkupManager.MergeMarkupAttributeAtRowCol(CurTextIndex+1, CurPos, NextPos, MarkupInfo); if NextPos < 1 then nX1 := rcLine.Right else begin nX1 := ScreenColumnToXValue(NextPos); if nX1 > rcLine.Right then nX1 := rcLine.Right; end; HasFrame := False; with fTextDrawer do begin SetBackColor(MarkupInfo.Background); SetForeColor(MarkupInfo.Foreground); SetStyle(MarkupInfo.Style); for s := low(TLazSynBorderSide) to high(TLazSynBorderSide) do begin HasFrame := HasFrame or (MarkupInfo.FrameSideColors[s] <> clNone); FrameColor[s] := MarkupInfo.FrameSideColors[s]; FrameStyle[s] := MarkupInfo.FrameSideStyles[s]; end; end; // Paint the chars rcToken.Right := ScreenColumnToXValue(TokenAccu.PhysicalEndPos+1); if nX1 > AClip.Right then begin fTextDrawer.FrameColor[bsRight] := clNone; // right side of char is not painted end; if nX1 > nRightEdge then begin if rcToken.Left < nRightEdge then begin tok := rcToken; tok.Right := nRightEdge; if (fsUnderline in MarkupInfo.Style) or (HasFrame) then fTextDrawer.ExtTextOut(tok.Right, tok.Top, ETOOptions, tok, @Spaces, 1, rcLine.Bottom) else InternalFillRect(dc, tok); rcToken.Left := nRightEdge; end; rcToken.Bottom := rcLine.Bottom; end; rcToken.Right := nX1; if (fsUnderline in MarkupInfo.Style) or (HasFrame) then fTextDrawer.ExtTextOut(rcToken.Right, rcToken.Top, ETOOptions, rcToken, @Spaces, 1, rcLine.Bottom) else InternalFillRect(dc, rcToken); rcToken.Left := nX1; until nX1 >= rcLine.Right; // Draw the right edge if necessary. if bDoRightEdge and (nRightEdge >= eolx) then begin // xx rc Token LCLIntf.MoveToEx(dc, nRightEdge, rcLine.Top, nil); LCLIntf.LineTo(dc, nRightEdge, rcLine.Bottom + 1); end; FreeAndNil(MarkupInfo); end; end; procedure AddHighlightToken(Token: PChar; TokenLen, PhysicalStartPos, PhysicalEndPos: integer; MarkupInfo : TSynSelectedColor); var CanAppend: boolean; SpacesTest, IsSpaces: boolean; i: integer; s: TLazSynBorderSide; function TokenIsSpaces: boolean; var pTok: PChar; Cnt: Integer; begin if not SpacesTest then begin SpacesTest := TRUE; IsSpaces := VisibleSpecialChars = []; pTok := PChar(Pointer(Token)); Cnt := TokenLen; while IsSpaces and (Cnt > 0) do begin if not (pTok^ in [' ',#9]) then IsSpaces := False; Inc(pTok); dec(Cnt); end; end; Result := IsSpaces; end; begin {DebugLn('AddHighlightToken A TokenLen=',dbgs(TokenLen), ' PhysicalStartPos=',dbgs(PhysicalStartPos),' PhysicalEndPos=',dbgs(PhysicalEndPos), ' Tok="',copy(Token,1,TokenLen),'"');} // Do we have to paint the old chars first, or can we just append? CanAppend := FALSE; SpacesTest := FALSE; if (TokenAccu.Len > 0) then begin CanAppend := // Frame can be continued (TokenAccu.FrameColor[bsTop] = MarkupInfo.FrameSideColors[bsTop]) and (TokenAccu.FrameStyle[bsTop] = MarkupInfo.FrameSideStyles[bsTop]) and (TokenAccu.FrameColor[bsBottom] = MarkupInfo.FrameSideColors[bsBottom]) and (TokenAccu.FrameStyle[bsBottom] = MarkupInfo.FrameSideStyles[bsBottom]) and (TokenAccu.FrameColor[bsRight] = clNone) and (MarkupInfo.FrameSideColors[bsLeft] = clNone) and // colors (TokenAccu.BG = MarkupInfo.Background) and // space-dependent ( ( (TokenAccu.FG = MarkupInfo.Foreground) and (TokenAccu.Style = MarkupInfo.Style) ) or // whitechar only token, can ignore Foreground color and certain styles (yet must match underline) ( (TokenAccu.Style - [fsBold, fsItalic] = MarkupInfo.Style - [fsBold, fsItalic]) and ( (TokenAccu.Style * [fsUnderline, fsStrikeOut] = []) or (TokenAccu.FG = MarkupInfo.Foreground) ) and TokenIsSpaces ) ); // If we can't append it, then we have to paint the old token chars first. if not CanAppend then PaintHighlightToken(FALSE); end; // Don't use AppendStr because it's more expensive. //if (CurLine=TopLine) then debugln(' -t-Accu len ',dbgs(TokenAccu.Len),' pstart ',dbgs(TokenAccu.PhysicalStartPos),' p-end ',dbgs(TokenAccu.PhysicalEndPos)); if CanAppend then begin if (TokenAccu.Len + TokenLen > TokenAccu.MaxLen) then begin TokenAccu.MaxLen := TokenAccu.Len + TokenLen + 32; SetTokenAccuLength; end; // use move() ??? for i := 0 to TokenLen-1 do begin TokenAccu.p[TokenAccu.Len + i] := Token[i]; end; Inc(TokenAccu.Len, TokenLen); TokenAccu.PhysicalEndPos := PhysicalEndPos; TokenAccu.FrameColor[bsRight] := MarkupInfo.FrameSideColors[bsRight]; TokenAccu.FrameStyle[bsRight] := MarkupInfo.FrameSideStyles[bsRight]; end else begin TokenAccu.Len := TokenLen; if (TokenAccu.Len > TokenAccu.MaxLen) then begin TokenAccu.MaxLen := TokenAccu.Len + 32; SetTokenAccuLength; end; for i := 0 to TokenLen-1 do begin TokenAccu.p[i] := Token[i]; end; TokenAccu.PhysicalStartPos := PhysicalStartPos; TokenAccu.PhysicalEndPos := PhysicalEndPos; TokenAccu.FG := MarkupInfo.Foreground; TokenAccu.BG := MarkupInfo.Background; TokenAccu.Style := MarkupInfo.Style; for s := low(TLazSynBorderSide) to high(TLazSynBorderSide) do begin TokenAccu.FrameColor[s] := MarkupInfo.FrameSideColors[s]; TokenAccu.FrameStyle[s] := MarkupInfo.FrameSideStyles[s]; end; end; {debugln('AddHighlightToken END CanAppend=',dbgs(CanAppend), ' Len=',dbgs(TokenAccu.Len), ' PhysicalStartPos=',dbgs(TokenAccu.PhysicalStartPos), ' PhysicalEndPos=',dbgs(TokenAccu.PhysicalEndPos), ' "',copy(TokenAccu.s,1,TokenAccu.Len),'"');} end; procedure DrawHiLightMarkupToken(attr: TSynHighlighterAttributes; sToken: PChar; nTokenByteLen: integer); var DefaultFGCol, DefaultBGCol: TColor; PhysicalStartPos: integer; PhysicalEndPos: integer; len: Integer; SubTokenByteLen, SubCharLen, TokenCharLen : Integer; NextPhysPos : Integer; function CharToByteLen(aCharLen: Integer) : Integer; begin if not fTextDrawer.UseUTF8 then exit(aCharLen); // tabs and double-width chars are padded with spaces Result := UTF8CharToByteIndex(sToken, nTokenByteLen, aCharLen); if Result < 0 then begin debugln('ERROR: Could not convert CharLen (',dbgs(aCharLen),') to byteLen (maybe invalid UTF8?)',' len ',dbgs(nTokenByteLen),' Line ',dbgs(CurLine),' PhysPos ',dbgs(CurPhysPos)); Result := aCharLen; end; end; procedure InitTokenColors; begin FPaintLineColor.Clear; if Assigned(attr) then begin DefaultFGCol := attr.Foreground; DefaultBGCol := attr.Background; if DefaultBGCol = clNone then DefaultBGCol := colEditorBG; if DefaultFGCol = clNone then DefaultFGCol := ForegroundColor; FPaintLineColor.Assign(attr); // TSynSelectedColor.Style and StyleMask describe how to modify a style, // but FPaintLineColor contains an actual style FPaintLineColor.MergeFinalStyle := True; FPaintLineColor.StyleMask := []; if FPaintLineColor.Background = clNone then FPaintLineColor.Background := colEditorBG; if FPaintLineColor.Foreground = clNone then FPaintLineColor.Foreground := ForegroundColor; FPaintLineColor.StartX := PhysicalStartPos; FPaintLineColor.EndX := PhysicalStartPos + TokenCharLen - 1; end else begin DefaultFGCol := ForegroundColor; DefaultBGCol := colEditorBG; FPaintLineColor.Style := []; // Font.Style; // currently always cleared end; FPaintLineColor.Foreground := DefaultFGCol; FPaintLineColor.Background := DefaultBGCol; end; begin if CurPhysPos > LastCol then exit; PhysicalStartPos := CurPhysPos; len := nTokenByteLen; TokenCharLen := ExpandSpecialChars(sToken, nTokenByteLen, PhysicalStartPos); CurLogIndex := CurLogIndex + len; // Prepare position for next token inc(CurPhysPos, TokenCharLen); if CurPhysPos <= FirstCol then exit; // Remove any Part of the Token that is before FirstCol if PhysicalStartPos < FirstCol then begin SubCharLen := FirstCol - PhysicalStartPos; len := CharToByteLen(SubCharLen); dec(TokenCharLen, SubCharLen); inc(PhysicalStartPos, SubCharLen); dec(nTokenByteLen, len); inc(sToken, len); end; // Remove any Part of the Token that is after LastCol SubCharLen := PhysicalStartPos + TokenCharLen - (LastCol + 1); if SubCharLen > 0 then begin dec(TokenCharLen, SubCharLen); nTokenByteLen := CharToByteLen(TokenCharLen); end; InitTokenColors; // Draw the token {TODO: cache NextPhysPos, and MarkupInfo between 2 calls } while (nTokenByteLen > 0) do begin FPaintLineColor2.Assign(FPaintLineColor); // Calculate Token Sublen for current Markup NextPhysPos := fMarkupManager.GetNextMarkupColAfterRowCol (CurTextIndex+1, PhysicalStartPos); if NextPhysPos < 1 then SubCharLen := TokenCharLen else SubCharLen := NextPhysPos - PhysicalStartPos; if SubCharLen > TokenCharLen then SubCharLen := TokenCharLen; if SubCharLen < 1 then begin // safety for broken input... debugln('ERROR: Got invalid SubCharLen ',dbgs(SubCharLen),' len ',dbgs(nTokenByteLen),' Line ',dbgs(CurLine),' PhysPos ',dbgs(CurPhysPos)); SubCharLen:=1; end; SubTokenByteLen := CharToByteLen(SubCharLen); PhysicalEndPos:= PhysicalStartPos + SubCharLen - 1; FPaintLineColor2.CurrentStartX := PhysicalStartPos; FPaintLineColor2.CurrentEndX := PhysicalEndPos; // Calculate Markup fMarkupManager.MergeMarkupAttributeAtRowCol(CurTextIndex+1, PhysicalStartPos, PhysicalEndPos, FPaintLineColor2); // Deal with equal colors if (FPaintLineColor2.Background = FPaintLineColor2.Foreground) then begin // or if diff(gb,fg) < x if FPaintLineColor2.Background = DefaultBGCol then FPaintLineColor2.Foreground := not(FPaintLineColor2.Background) and $00ffffff // or maybe ForegroundColor ? else FPaintLineColor2.Foreground := DefaultBGCol; end; // Add to TokenAccu AddHighlightToken(sToken, SubTokenByteLen, PhysicalStartPos, PhysicalEndPos, FPaintLineColor2); PhysicalStartPos:=PhysicalEndPos + 1; dec(nTokenByteLen,SubTokenByteLen); dec(TokenCharLen, SubCharLen); inc(sToken, SubTokenByteLen); end; end; {$IFDEF SYNDEBUGPRINT} procedure DebugPrint(Txt: String; MinCol: Integer = 0); begin if CurPhysPos < MinCol then Txt := StringOfChar(' ', MinCol - CurPhysPos) + txt; Setlength(CharWidths, length(CharWidths) + length(Txt)); FillChar(CharWidths[length(CharWidths)-length(Txt)], length(Txt), #1); DrawHiLightMarkupToken(nil, PChar(Pointer(Txt)), Length(Txt)); end; {$ENDIF} procedure PaintLines; var ypos: Integer; DividerInfo: TSynDividerDrawConfigSetting; TV, cl: Integer; TokenInfo: TLazSynDisplayTokenInfo; MaxLine: Integer; begin // Initialize rcLine for drawing. Note that Top and Bottom are updated // inside the loop. Get only the starting point for this. rcLine := AClip; rcLine.Bottom := TextBounds.Top + FirstLine * fTextHeight; TV := TopLine - 1; // Now loop through all the lines. The indices are valid for Lines. MaxLine := DisplayView.GetLinesCount-1; CurLine := FirstLine-1; while CurLine MaxLine then break; // Update the rcLine rect to this line. rcLine.Top := rcLine.Bottom; Inc(rcLine.Bottom, fTextHeight); // Paint the lines depending on the assigned highlighter. rcToken := rcLine; TokenAccu.Len := 0; TokenAccu.PhysicalEndPos := FirstCol - 1; // in case of an empty line CurPhysPos := 1; CurLogIndex := 0; // Delete the whole Line fTextDrawer.BackColor := colEditorBG; SetBkColor(dc, ColorToRGB(colEditorBG)); rcLine.Left := EraseLeft; InternalFillRect(dc, rcLine); rcLine.Left := DrawLeft; ForceEto := False; DisplayView.SetHighlighterTokensLine(TV + CurLine, CurTextIndex); CharWidths := FTheLinesView.GetPhysicalCharWidths(CurTextIndex); fMarkupManager.PrepareMarkupForRow(CurTextIndex+1); DividerInfo := DisplayView.GetDrawDividerInfo; if (DividerInfo.Color <> clNone) and (nRightEdge >= FTextBounds.Left) then begin ypos := rcToken.Bottom - 1; cl := DividerInfo.Color; if cl = clDefault then cl := RightEdgeColor; fTextDrawer.DrawLine(nRightEdge, ypos, FTextBounds.Left - 1, ypos, cl); dec(rcToken.Bottom); end; while DisplayView.GetNextHighlighterToken(TokenInfo) do begin DrawHiLightMarkupToken(TokenInfo.TokenAttr, TokenInfo.TokenStart, TokenInfo.TokenLength); end; // Draw anything that's left in the TokenAccu record. Fill to the end // of the invalid area with the correct colors. PaintHighlightToken(TRUE); fMarkupManager.FinishMarkupForRow(CurTextIndex+1); end; CurLine:=-1; AClip.Top := rcLine.Bottom; end; { end local procedures } begin //if (AClip.Right < TextLeftPixelOffset(False)) then exit; //if (AClip.Left > ClientWidth - TextRightPixelOffset) then exit; //DebugLn(['TCustomSynEdit.PaintTextLines ',dbgs(AClip)]); CurLine:=-1; //DebugLn('TCustomSynEdit.PaintTextLines ',DbgSName(Self),' TopLine=',dbgs(TopLine),' AClip=',dbgs(AClip)); colEditorBG := BackgroundColor; // If the right edge is visible and in the invalid area, prepare to paint it. // Do this first to realize the pen when getting the dc variable. bDoRightEdge := FALSE; if FRightEdgeVisible then begin // column value nRightEdge := FTextBounds.Left + (RightEdgeColumn - LeftChar + 1) * CharWidth; // pixel value if (nRightEdge >= AClip.Left) and (nRightEdge <= AClip.Right) then bDoRightEdge := TRUE; if nRightEdge > AClip.Right then nRightEdge := AClip.Right; // for divider draw lines (don't draw into right gutter) end else nRightEdge := AClip.Right; Canvas.Pen.Color := RightEdgeColor; // used for code folding too Canvas.Pen.Width := 1; // Do everything else with API calls. This (maybe) realizes the new pen color. dc := Canvas.Handle; SetBkMode(dc, TRANSPARENT); // Adjust the invalid area to not include the gutter (nor the 2 ixel offset to the guttter). EraseLeft := AClip.Left; if (AClip.Left < FTextBounds.Left) then AClip.Left := FTextBounds.Left ; DrawLeft := AClip.Left; if (LastLine >= FirstLine) then begin // Paint the visible text lines. To make this easier, compute first the // necessary information about the selected area: is there any visible // selected area, and what are its lines / columns? // Moved to two local procedures to make it easier to read. FillChar(TokenAccu,SizeOf(TokenAccu),0); if Assigned(fHighlighter) then begin fHighlighter.CurrentLines := FTheLinesView; // Make sure the token accumulator string doesn't get reassigned to often. TokenAccu.MaxLen := Max(128, fCharsInWindow * 4); SetTokenAccuLength; end; DisplayView.InitHighlighterTokens(FHighlighter); fTextDrawer.Style := []; //Font.Style; fTextDrawer.BeginDrawing(dc); try PaintLines; finally fTextDrawer.EndDrawing; DisplayView.FinishHighlighterTokens; ReAllocMem(TokenAccu.p,0); end; end; if (AClip.Top < AClip.Bottom) then begin // Delete the remaining area SetBkColor(dc, ColorToRGB(colEditorBG)); AClip.Left := EraseLeft; InternalFillRect(dc, AClip); AClip.Left := DrawLeft; // Draw the right edge if necessary. if bDoRightEdge then begin LCLIntf.MoveToEx(dc, nRightEdge, AClip.Top, nil); LCLIntf.LineTo(dc, nRightEdge, AClip.Bottom + 1); end; end; fMarkupManager.EndMarkup; end; end.