1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436 | -- part of AdaYaml, (c) 2017 Felix Krause
-- released under the terms of the MIT license, see the file "copying.txt"
with Ada.Finalization;
with Ada.Unchecked_Deallocation;
with AUnit.Assertions; use AUnit.Assertions;
package body Yaml.Lexer.Tokenization_Test is
use type Text.Reference;
subtype Evaluated_Token is Token_Kind with Static_Predicate =>
Evaluated_Token in Scalar_Token_Kind | Suffix | Verbatim_Tag;
subtype Short_Lexeme_Token is Token_Kind with Static_Predicate =>
Short_Lexeme_Token in Unknown_Directive | Anchor | Alias;
subtype Full_Lexeme_Token is Token_Kind with Static_Predicate =>
Full_Lexeme_Token in Directive_Param | Tag_Handle;
subtype Value_Token is Token_Kind with Static_Predicate =>
Value_Token in Evaluated_Token | Short_Lexeme_Token | Full_Lexeme_Token;
subtype Empty_Token is Token_Kind with Static_Predicate =>
not (Empty_Token in Value_Token | Indentation);
type Token_With_Value_Holder (Kind : Token_Kind) is record
Refcount : Natural := 1;
case Kind is
when Value_Token => Value : Text.Reference;
when Indentation => Depth : Natural;
when others => null;
end case;
end record;
type Token_With_Value_Holder_Access is access Token_With_Value_Holder;
type Token_With_Value is new Ada.Finalization.Controlled with record
Reference : Token_With_Value_Holder_Access;
end record;
overriding procedure Adjust (Object : in out Token_With_Value);
overriding procedure Finalize (Object : in out Token_With_Value);
procedure Adjust (Object : in out Token_With_Value) is
begin
if Object.Reference /= null then
Object.Reference.Refcount := Object.Reference.Refcount + 1;
end if;
end Adjust;
procedure Finalize (Object : in out Token_With_Value) is
procedure Free is new Ada.Unchecked_Deallocation
(Token_With_Value_Holder, Token_With_Value_Holder_Access);
Reference : Token_With_Value_Holder_Access := Object.Reference;
begin
Object.Reference := null;
if Reference /= null then
Reference.Refcount := Reference.Refcount - 1;
if Reference.Refcount = 0 then
Free (Reference);
end if;
end if;
end Finalize;
function To_String (T : Token_With_Value) return String is
(T.Reference.Kind'Img &
(case T.Reference.Kind is
when Value_Token => '(' & Escaped (T.Reference.Value) & ')',
when Indentation => '(' & T.Reference.Depth'Img & ')',
when others => ""));
type Token_List is array (Positive range <>) of Token_With_Value;
function TI (Indent : Natural) return Token_With_Value is
(Token_With_Value'(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1,
Kind => Indentation,
Depth => Indent)));
function With_String (Tok : Value_Token; S : String;
T : in out Test_Cases.Test_Case'Class)
return Token_With_Value is
begin
return V : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference => new Token_With_Value_Holder (Kind => Tok)) do
V.Reference.Refcount := 1;
V.Reference.Value := TC (T).Pool.From_String (S);
end return;
end With_String;
function TPS (T : in out Test_Cases.Test_Case'Class;
Content : String) return Token_With_Value is
(With_String (Plain_Scalar, Content, T));
function TSQS (T : in out Test_Cases.Test_Case'Class;
Content : String) return Token_With_Value is
(With_String (Single_Quoted_Scalar, Content, T));
function TDQS (T : in out Test_Cases.Test_Case'Class;
Content : String) return Token_With_Value is
(With_String (Double_Quoted_Scalar, Content, T));
function TLS (T : in out Test_Cases.Test_Case'Class;
Content : String) return Token_With_Value is
(With_String (Literal_Scalar, Content, T));
function TFS (T : in out Test_Cases.Test_Case'Class;
Content : String) return Token_With_Value is
(With_String (Folded_Scalar, Content, T));
TStrE : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1, Kind => Stream_End));
TMK : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1, Kind => Map_Key_Ind));
TMV : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1, Kind => Map_Value_Ind));
TMS : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1, Kind => Flow_Map_Start));
TME : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1, Kind => Flow_Map_End));
TSep : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1, Kind => Flow_Separator));
TSS : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1, Kind => Flow_Seq_Start));
TSE : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1, Kind => Flow_Seq_End));
TSI : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1, Kind => Seq_Item_Ind));
TYD : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1, Kind => Yaml_Directive));
TTD : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1, Kind => Tag_Directive));
TDirE : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1, Kind => Directives_End));
TDocE : constant Token_With_Value :=
(Ada.Finalization.Controlled with Reference =>
new Token_With_Value_Holder'(Refcount => 1, Kind => Document_End));
function TDP (T : in out Test_Cases.Test_Case'Class; Content : String)
return Token_With_Value is
(With_String (Directive_Param, Content, T));
function TTH (T : in out Test_Cases.Test_Case'Class; Content : String)
return Token_With_Value is
(With_String (Tag_Handle, Content, T));
function TTV (T : in out Test_Cases.Test_Case'Class; Content : String)
return Token_With_Value is
(With_String (Verbatim_Tag, Content, T));
function TTU (T : in out Test_Cases.Test_Case'Class; Content : String)
return Token_With_Value is
(With_String (Suffix, Content, T));
function TUD (T : in out Test_Cases.Test_Case'Class; Content : String)
return Token_With_Value is
(With_String (Unknown_Directive, Content, T));
function TAn (T : in out Test_Cases.Test_Case'Class; Content : String)
return Token_With_Value is
(With_String (Anchor, Content, T));
function TAli (T : in out Test_Cases.Test_Case'Class; Content : String)
return Token_With_Value is
(With_String (Alias, Content, T));
function To_String (L : Instance; T : Token_Kind) return String is
(T'Img & (case T is
when Evaluated_Token => '(' & Escaped (L.Value) & ')',
when Short_Lexeme_Token => '(' & Escaped (Short_Lexeme (L)) & ')',
when Full_Lexeme_Token => '(' & Escaped (Full_Lexeme (L)) & ')',
when Empty_Token => "",
when Indentation => '(' & Natural'(L.Pos - L.Line_Start - 1)'Img & ')'));
procedure Assert_Equals (P : Text.Pool.Reference;
Input : String; Expected : Token_List) is
L : Instance;
I : Natural := 0;
begin
Init (L, Input, P);
for Expected_Token of Expected loop
I := I + 1;
declare
T : constant Token := Next_Token (L);
begin
Assert (T.Kind = Expected_Token.Reference.Kind,
"Wrong token kind at #" & I'Img & ": Expected " &
To_String (Expected_Token) & ", got " &
To_String (L, T.Kind));
if T.Kind = Expected_Token.Reference.Kind then
case T.Kind is
when Evaluated_Token =>
Assert (L.Value = Expected_Token.Reference.Value,
"Wrong content at #" & I'Img & ": Expected " &
Escaped (Expected_Token.Reference.Value) &
", got " & Escaped (L.Value));
when Full_Lexeme_Token =>
Assert (Full_Lexeme (L) = Expected_Token.Reference.Value,
"Wrong " & T.Kind'Img & " at #" & I'Img & ": Expected " &
Escaped (Expected_Token.Reference.Value) &
", got " & Escaped (Full_Lexeme (L)));
when Short_Lexeme_Token =>
Assert (Short_Lexeme (L) = Expected_Token.Reference.Value,
"Wrong " & T.Kind'Img & "at #" & I'Img & ": Expected " &
Escaped (Expected_Token.Reference.Value) &
", got " & Escaped (Short_Lexeme (L)));
when Indentation =>
Assert (L.Pos - L.Line_Start - 1 = Expected_Token.Reference.Depth,
"Wrong indentation at #" & I'Img & ": Expected" &
Expected_Token.Reference.Depth'Img & ", got " &
Integer'(L.Pos - L.Line_Start - 2)'Img);
when Empty_Token => null;
end case;
end if;
end;
end loop;
end Assert_Equals;
procedure Register_Tests (T : in out TC) is
use AUnit.Test_Cases.Registration;
begin
Register_Routine (T, Empty_Document'Access, "Empty document");
Register_Routine (T, Single_Line_Scalar'Access, "Single line scalar");
Register_Routine (T, Multiline_Scalar'Access, "Multiline scalar");
Register_Routine (T, Single_Line_Mapping'Access, "Single line mapping");
Register_Routine (T, Multiline_Mapping'Access, "Multiline mapping");
Register_Routine (T, Explicit_Mapping'Access, "Explicit mapping");
Register_Routine (T, Sequence'Access, "Sequence");
Register_Routine (T, Sequence_With_Block_Mappings'Access, "Sequence with block mappings");
Register_Routine (T, Single_Quoted_Scalar'Access, "Single-line single quoted scalar");
Register_Routine (T, Multiline_Single_Quoted_Scalar'Access, "Multiline single quoted scalar");
Register_Routine (T, Double_Quoted_Scalar'Access, "Single-line double quoted scalar");
Register_Routine (T, Multiline_Double_Quoted_Scalar'Access, "Multiline double quoted scalar");
Register_Routine (T, Escape_Sequences'Access, "Escape sequences");
Register_Routine (T, Block_Scalar'Access, "Block scalar");
Register_Routine (T, Block_Scalars'Access, "Block scalars");
Register_Routine (T, Directives'Access, "Directives");
Register_Routine (T, Markers'Access, "Markers and unknown directives");
Register_Routine (T, Flow_Indicators'Access, "Flow indicators");
Register_Routine (T, Adjacent_Map_Values'Access, "Adjacent map values (JSON-style)");
Register_Routine (T, Tag_Handles'Access, "Tag handles");
Register_Routine (T, Verbatim_Tag_Handle'Access, "Verbatim tag handle");
Register_Routine (T, Anchors_And_Aliases'Access, "Anchors and aliases");
Register_Routine (T, Empty_Lines'Access, "Empty lines");
end Register_Tests;
function Name (T : TC) return Message_String is
pragma Unreferenced (T);
begin
return AUnit.Format ("Tokenization tests for Lexer");
end Name;
procedure Set_Up (T : in out TC) is
begin
T.Pool.Create (8092);
end Set_Up;
procedure Empty_Document (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "", (1 => TStrE));
end Empty_Document;
procedure Single_Line_Scalar (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "scalar",
(TI (0), TPS (T, "scalar"), TStrE));
end Single_Line_Scalar;
procedure Multiline_Scalar (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "scalar" & Line_Feed & " line two",
(TI (0), TPS (T, "scalar line two"), TStrE));
end Multiline_Scalar;
procedure Single_Line_Mapping (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "key: value",
(TI (0), TPS (T, "key"), TMV, TPS (T, "value"), TStrE));
end Single_Line_Mapping;
procedure Multiline_Mapping (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "key:" & Line_Feed & " value",
(TI (0), TPS (T, "key"), TMV, TI (2), TPS (T, "value"),
TStrE));
end Multiline_Mapping;
procedure Explicit_Mapping (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "? key" & Line_Feed & ": value",
(TI (0), TMK, TPS (T, "key"), TI (0), TMV,
TPS (T, "value"), TStrE));
end Explicit_Mapping;
procedure Sequence (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "- a" & Line_Feed & "- b",
(TI (0), TSI, TPS (T, "a"), TI (0), TSI, TPS (T, "b"),
TStrE));
end Sequence;
procedure Sequence_With_Block_Mappings (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "-" & Line_Feed & " avg: 0.228",
(TI (0), TSI, TI (2), TPS (T, "avg"), TMV,
TPS (T, "0.228"), TStrE));
end Sequence_With_Block_Mappings;
procedure Single_Quoted_Scalar (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "'quoted scalar'",
(TI (0), TSQS (T, "quoted scalar"), TStrE));
end Single_Quoted_Scalar;
procedure Multiline_Single_Quoted_Scalar
(T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "'quoted" & Line_Feed &
" multi line " & Line_Feed & Line_Feed & "scalar'",
(TI (0),
TSQS (T, "quoted multi line" & Line_Feed & "scalar"),
TStrE));
end Multiline_Single_Quoted_Scalar;
procedure Double_Quoted_Scalar (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, """quoted scalar""",
(TI (0), TDQS (T, "quoted scalar"), TStrE));
end Double_Quoted_Scalar;
procedure Multiline_Double_Quoted_Scalar
(T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, """quoted" & Line_Feed &
" multi line " & Line_Feed & Line_Feed & "scalar""",
(TI (0),
TDQS (T, "quoted multi line" & Line_Feed & "scalar"),
TStrE));
end Multiline_Double_Quoted_Scalar;
procedure Escape_Sequences (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, """\n\x31\u0032\U00000033""",
(TI (0), TDQS (T, Line_Feed & "123"), TStrE));
end Escape_Sequences;
procedure Block_Scalar (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "|" & Line_Feed & " a" & Line_Feed &
Line_Feed & " b" & Line_Feed & " # comment",
(TI (0),
TLS (T, "a" & Line_Feed & Line_Feed & "b" & Line_Feed),
TStrE));
end Block_Scalar;
procedure Block_Scalars (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "one : >2-" & Line_Feed & " foo" &
Line_Feed & " bar" & Line_Feed & "two: |+" & Line_Feed &
" bar" & Line_Feed & " baz" & Line_Feed & Line_Feed,
(TI (0), TPS (T, "one"), TMV, TFS (T, " foo bar"), TI (0),
TPS (T, "two"), TMV,
TLS (T, "bar" & Line_Feed & " baz" & Line_Feed & Line_Feed),
TStrE));
end Block_Scalars;
procedure Directives (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "%YAML 1.3" & Line_Feed & "---" &
Line_Feed & "%TAG" & Line_Feed & "..." & Line_Feed &
Line_Feed & "%TAG ! example%20.html",
(TYD, TDP (T, "1.3"), TDirE, TI (0), TPS (T, "%TAG"),
TDocE, TTD, TTH (T, "!"), TTU (T, "example .html"),
TStrE));
end Directives;
procedure Markers (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "---" & Line_Feed & "---" & Line_Feed &
"..." & Line_Feed & "%UNKNOWN warbl",
(TDirE, TDirE, TDocE, TUD (T, "UNKNOWN"),
TDP (T, "warbl"), TStrE));
end Markers;
procedure Flow_Indicators (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "bla]: {c: d, [e]: f}",
(TI (0), TPS (T, "bla]"), TMV, TMS, TPS (T, "c"), TMV,
TPS (T, "d"), TSep, TSS, TPS (T, "e"), TSE, TMV,
TPS (T, "f"), TME, TStrE));
end Flow_Indicators;
procedure Adjacent_Map_Values (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "{""foo"":bar, [1]" & Line_Feed &
":egg}",
(TI (0), TMS, TDQS (T, "foo"), TMV, TPS (T, "bar"), TSep,
TSS, TPS (T, "1"), TSE, TMV, TPS (T, "egg"), TME, TStrE));
end Adjacent_Map_Values;
procedure Tag_Handles (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "- !!str string" & Line_Feed &
"- !local%21 local" & Line_Feed & "- !e! e",
(TI (0), TSI, TTH (T, "!!"), TTU (T, "str"),
TPS (T, "string"), TI (0), TSI, TTH (T, "!"),
TTU (T, "local!"), TPS (T, "local"), TI (0), TSI,
TTH (T, "!e!"), TTU (T, ""), TPS (T, "e"), TStrE));
end Tag_Handles;
procedure Verbatim_Tag_Handle (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "!<tag:yaml.org,2002:str> string",
(TI (0), TTV (T, "tag:yaml.org,2002:str"),
TPS (T, "string"), TStrE));
end Verbatim_Tag_Handle;
procedure Anchors_And_Aliases (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "&a foo: {&b b: *a, *b : c}",
(TI (0), TAn (T, "a"), TPS (T, "foo"), TMV, TMS,
TAn (T, "b"), TPS (T, "b"), TMV, TAli (T, "a"), TSep,
TAli (T, "b"), TMV, TPS (T, "c"), TME, TStrE));
end Anchors_And_Aliases;
procedure Empty_Lines (T : in out Test_Cases.Test_Case'Class) is
begin
Assert_Equals (TC (T).Pool, "block: foo" & Line_Feed & Line_Feed &
" bar" & Line_Feed & Line_Feed & " baz" & Line_Feed &
"flow: {" & Line_Feed & " foo" & Line_Feed & Line_Feed &
" bar: baz" & Line_Feed & Line_Feed & Line_Feed &
" mi" & Line_Feed & "}",
(TI (0), TPS (T, "block"), TMV,
TPS (T, "foo" & Line_Feed & "bar" & Line_Feed & "baz"),
TI (0), TPS (T, "flow"), TMV, TMS,
TPS (T, "foo" & Line_Feed & "bar"), TMV,
TPS (T, "baz" & Line_Feed & Line_Feed & "mi"),
TME, TStrE));
end Empty_Lines;
end Yaml.Lexer.Tokenization_Test;
|