← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to examples/SynEdit/NewHighlighterTutorial/foldhl.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
examples/SynEdit/NewHighlighterTutorial/foldhl.pas
 
1
unit FoldHl;
 
2
(*
 
3
  This is an example how to implement your own highlighter.
 
4
 
 
5
  This example extends the Simple and Context HL:
 
6
  - The token -(- and -)- (must be surrounded by space or line-begin/end to be
 
7
    a token of their own) will add foldable sections
 
8
 
 
9
    Multply -(- and -)- can be nested.
 
10
 
 
11
  See comments below and http://wiki.lazarus.freepascal.org/SynEdit_Highlighter
 
12
 
 
13
*)
 
14
 
 
15
{$mode objfpc}{$H+}
 
16
 
 
17
interface
 
18
 
 
19
uses
 
20
  Classes, SysUtils, Graphics, SynEditTypes, SynEditHighlighter, SynEditHighlighterFoldBase, ContextHL;
 
21
 
 
22
type
 
23
 
 
24
  (*   This is an EXACT COPY of SynEditHighlighter
 
25
 
 
26
       ONLY the base class is changed to add support for folding
 
27
 
 
28
       The new code follows below
 
29
  *)
 
30
 
 
31
  TSynDemoHlFoldBase = class(TSynCustomFoldHighlighter)
 
32
  private
 
33
    FNotAttri: TSynHighlighterAttributes;
 
34
    fSpecialAttri: TSynHighlighterAttributes;
 
35
    fIdentifierAttri: TSynHighlighterAttributes;
 
36
    fSpaceAttri: TSynHighlighterAttributes;
 
37
    procedure SetIdentifierAttri(AValue: TSynHighlighterAttributes);
 
38
    procedure SetNotAttri(AValue: TSynHighlighterAttributes);
 
39
    procedure SetSpaceAttri(AValue: TSynHighlighterAttributes);
 
40
    procedure SetSpecialAttri(AValue: TSynHighlighterAttributes);
 
41
  protected
 
42
    // accesible for the other examples
 
43
    FTokenPos, FTokenEnd: Integer;
 
44
    FLineText: String;
 
45
  public
 
46
    procedure SetLine(const NewValue: String; LineNumber: Integer); override;
 
47
    procedure Next; override;
 
48
    function  GetEol: Boolean; override;
 
49
    procedure GetTokenEx(out TokenStart: PChar; out TokenLength: integer); override;
 
50
    function  GetTokenAttribute: TSynHighlighterAttributes; override;
 
51
  public
 
52
    function GetToken: String; override;
 
53
    function GetTokenPos: Integer; override;
 
54
    function GetTokenKind: integer; override;
 
55
    function GetDefaultAttribute(Index: integer): TSynHighlighterAttributes; override;
 
56
    constructor Create(AOwner: TComponent); override;
 
57
  published
 
58
    (* Define 4 Attributes, for the different highlights. *)
 
59
    property SpecialAttri: TSynHighlighterAttributes read fSpecialAttri
 
60
      write SetSpecialAttri;
 
61
    property NotAttri: TSynHighlighterAttributes read FNotAttri
 
62
      write SetNotAttri;
 
63
    property IdentifierAttri: TSynHighlighterAttributes read fIdentifierAttri
 
64
      write SetIdentifierAttri;
 
65
    property SpaceAttri: TSynHighlighterAttributes read fSpaceAttri
 
66
      write SetSpaceAttri;
 
67
  end;
 
68
 
 
69
  (*   This is a COPY of SynEditHighlighter
 
70
 
 
71
       ONLY the base class is changed to add support for folding
 
72
 
 
73
       The new code follows below
 
74
  *)
 
75
 
 
76
  TSynDemoHlContextFoldBase = class(TSynDemoHlFoldBase)
 
77
  protected
 
78
    FCurRange: Integer;
 
79
  public
 
80
    procedure Next; override;
 
81
    function GetTokenAttribute: TSynHighlighterAttributes; override;
 
82
  public
 
83
  (* The below needed to be changed and are in TSynDemoHlFold
 
84
     TSynDemoHlContextFoldBase uses Ranges itself.
 
85
     The Range needed here is therefore stored in a diff location
 
86
  *)
 
87
    //procedure SetRange(Value: Pointer); override;
 
88
    //procedure ResetRange; override;
 
89
    //function GetRange: Pointer; override;
 
90
  end;
 
91
 
 
92
  { TSynDemoHlContext }
 
93
 
 
94
  (* You can base this on either
 
95
     TSynDemoHlFoldBase or TSynDemoHlContextFoldBase
 
96
 
 
97
     Using ranges is NOT a condition for fold.
 
98
     (If changing, remove Range related code)
 
99
 
 
100
     Note that ranges to change.
 
101
  *)
 
102
 
 
103
  //TSynDemoHlFold = class(TSynDemoHlFoldBase)
 
104
  TSynDemoHlFold = class(TSynDemoHlContextFoldBase)
 
105
  public
 
106
    procedure Next; override;
 
107
  public
 
108
    procedure SetRange(Value: Pointer); override;
 
109
    procedure ResetRange; override;
 
110
    function GetRange: Pointer; override;
 
111
  end;
 
112
 
 
113
implementation
 
114
 
 
115
{ TSynDemoHlFold }
 
116
 
 
117
procedure TSynDemoHlFold.Next;
 
118
begin
 
119
  inherited Next;
 
120
  if (copy(FLineText, FTokenPos, FTokenEnd - FTokenPos) = '-(-') then
 
121
    StartCodeFoldBlock(nil);
 
122
  if (copy(FLineText, FTokenPos, FTokenEnd - FTokenPos) = '-)-') then
 
123
    EndCodeFoldBlock;
 
124
end;
 
125
 
 
126
procedure TSynDemoHlFold.SetRange(Value: Pointer);
 
127
begin
 
128
  // must call the SetRange in TSynCustomFoldHighlighter
 
129
  inherited SetRange(Value);
 
130
  FCurRange := PtrInt(CodeFoldRange.RangeType);
 
131
 end;
 
132
 
 
133
procedure TSynDemoHlFold.ResetRange;
 
134
begin
 
135
  inherited ResetRange;
 
136
  FCurRange := 0;
 
137
end;
 
138
 
 
139
function TSynDemoHlFold.GetRange: Pointer;
 
140
begin
 
141
  // Store the range first
 
142
  CodeFoldRange.RangeType := Pointer(PtrInt(FCurRange));
 
143
  Result := inherited GetRange;
 
144
end;
 
145
 
 
146
 
 
147
(*   This is an EXACT COPY of SynEditHighlighter
 
148
 
 
149
     ONLY the base class is changed to add support for folding
 
150
*)
 
151
 
 
152
constructor TSynDemoHlFoldBase.Create(AOwner: TComponent);
 
153
begin
 
154
  inherited Create(AOwner);
 
155
 
 
156
  (* Create and initialize the attributes *)
 
157
  fSpecialAttri := TSynHighlighterAttributes.Create('special', 'special');
 
158
  AddAttribute(fSpecialAttri);
 
159
  fSpecialAttri.Style := [fsBold];
 
160
 
 
161
  FNotAttri := TSynHighlighterAttributes.Create('not', 'not');
 
162
  AddAttribute(FNotAttri);
 
163
  FNotAttri.Background := clRed;
 
164
 
 
165
  fIdentifierAttri := TSynHighlighterAttributes.Create('ident', 'ident');
 
166
  AddAttribute(fIdentifierAttri);
 
167
 
 
168
  fSpaceAttri := TSynHighlighterAttributes.Create('space', 'space');
 
169
  AddAttribute(fSpaceAttri);
 
170
  fSpaceAttri.FrameColor := clSilver;
 
171
  fSpaceAttri.FrameEdges := sfeAround;
 
172
end;
 
173
 
 
174
(* Setters for attributes / This allows using in Object inspector*)
 
175
procedure TSynDemoHlFoldBase.SetIdentifierAttri(AValue: TSynHighlighterAttributes);
 
176
begin
 
177
  fIdentifierAttri.Assign(AValue);
 
178
end;
 
179
 
 
180
procedure TSynDemoHlFoldBase.SetNotAttri(AValue: TSynHighlighterAttributes);
 
181
begin
 
182
  FNotAttri.Assign(AValue);
 
183
end;
 
184
 
 
185
procedure TSynDemoHlFoldBase.SetSpaceAttri(AValue: TSynHighlighterAttributes);
 
186
begin
 
187
  fSpaceAttri.Assign(AValue);
 
188
end;
 
189
 
 
190
procedure TSynDemoHlFoldBase.SetSpecialAttri(AValue: TSynHighlighterAttributes);
 
191
begin
 
192
  fSpecialAttri.Assign(AValue);
 
193
end;
 
194
 
 
195
procedure TSynDemoHlFoldBase.SetLine(const NewValue: String; LineNumber: Integer);
 
196
begin
 
197
  inherited;
 
198
  FLineText := NewValue;
 
199
  // Next will start at "FTokenEnd", so set this to 1
 
200
  FTokenEnd := 1;
 
201
  Next;
 
202
end;
 
203
 
 
204
procedure TSynDemoHlFoldBase.Next;
 
205
var
 
206
  l: Integer;
 
207
begin
 
208
  // FTokenEnd should be at the start of the next Token (which is the Token we want)
 
209
  FTokenPos := FTokenEnd;
 
210
  // assume empty, will only happen for EOL
 
211
  FTokenEnd := FTokenPos;
 
212
 
 
213
  // Scan forward
 
214
  // FTokenEnd will be set 1 after the last char. That is:
 
215
  // - The first char of the next token
 
216
  // - or past the end of line (which allows GetEOL to work)
 
217
 
 
218
  l := length(FLineText);
 
219
  If FTokenPos > l then
 
220
    // At line end
 
221
    exit
 
222
  else
 
223
  if FLineText[FTokenEnd] in [#9, ' '] then
 
224
    // At Space? Find end of spaces
 
225
    while (FTokenEnd <= l) and (FLineText[FTokenEnd] in [#0..#32]) do inc (FTokenEnd)
 
226
  else
 
227
    // At None-Space? Find end of None-spaces
 
228
    while (FTokenEnd <= l) and not(FLineText[FTokenEnd] in [#9, ' ']) do inc (FTokenEnd)
 
229
end;
 
230
 
 
231
function TSynDemoHlFoldBase.GetEol: Boolean;
 
232
begin
 
233
  Result := FTokenPos > length(FLineText);
 
234
end;
 
235
 
 
236
procedure TSynDemoHlFoldBase.GetTokenEx(out TokenStart: PChar; out TokenLength: integer);
 
237
begin
 
238
  TokenStart := @FLineText[FTokenPos];
 
239
  TokenLength := FTokenEnd - FTokenPos;
 
240
end;
 
241
 
 
242
function TSynDemoHlFoldBase.GetTokenAttribute: TSynHighlighterAttributes;
 
243
begin
 
244
  // Match the text, specified by FTokenPos and FTokenEnd
 
245
 
 
246
  if FLineText[FTokenPos] in [#9, ' '] then
 
247
    Result := SpaceAttri
 
248
  else
 
249
  if LowerCase(FLineText[FTokenPos]) in ['a', 'e', 'i', 'o', 'u'] then
 
250
    Result := SpecialAttri
 
251
  else
 
252
  if LowerCase(copy(FLineText, FTokenPos, FTokenEnd - FTokenPos)) = 'not' then
 
253
    Result := NotAttri
 
254
  else
 
255
    Result := IdentifierAttri;
 
256
end;
 
257
 
 
258
function TSynDemoHlFoldBase.GetToken: String;
 
259
begin
 
260
  Result := copy(FLineText, FTokenPos, FTokenEnd - FTokenPos);
 
261
end;
 
262
 
 
263
function TSynDemoHlFoldBase.GetTokenPos: Integer;
 
264
begin
 
265
  Result := FTokenPos - 1;
 
266
end;
 
267
 
 
268
function TSynDemoHlFoldBase.GetDefaultAttribute(Index: integer): TSynHighlighterAttributes;
 
269
begin
 
270
  // Some default attributes
 
271
  case Index of
 
272
    SYN_ATTR_COMMENT: Result := fSpecialAttri;
 
273
    SYN_ATTR_IDENTIFIER: Result := fIdentifierAttri;
 
274
    SYN_ATTR_WHITESPACE: Result := fSpaceAttri;
 
275
    else Result := nil;
 
276
  end;
 
277
end;
 
278
 
 
279
function TSynDemoHlFoldBase.GetTokenKind: integer;
 
280
var
 
281
  a: TSynHighlighterAttributes;
 
282
begin
 
283
  // Map Attribute into a unique number
 
284
  a := GetTokenAttribute;
 
285
  Result := 0;
 
286
  if a = fSpaceAttri then Result := 1;
 
287
  if a = fSpecialAttri then Result := 2;
 
288
  if a = fIdentifierAttri then Result := 3;
 
289
  if a = FNotAttri then Result := 4;
 
290
end;
 
291
 
 
292
 
 
293
(*   This is an EXACT COPY of SynEditHighlighter
 
294
 
 
295
     ONLY the base class is changed to add support for folding
 
296
*)
 
297
 
 
298
procedure TSynDemoHlContextFoldBase.Next;
 
299
begin
 
300
  inherited Next;
 
301
  if (copy(FLineText, FTokenPos, FTokenEnd - FTokenPos) = '--') then
 
302
    inc(FCurRange);
 
303
  if (copy(FLineText, FTokenPos, FTokenEnd - FTokenPos) = '++') and (FCurRange > 0) then
 
304
    dec(FCurRange);
 
305
end;
 
306
 
 
307
function TSynDemoHlContextFoldBase.GetTokenAttribute: TSynHighlighterAttributes;
 
308
begin
 
309
  Result := inherited GetTokenAttribute;
 
310
  if (Result = SpecialAttri) and (FCurRange > 0) then
 
311
    Result := IdentifierAttribute;
 
312
end;
 
313
 
 
314
 
 
315
end.
 
316