Skip to content

Commit b93bd59

Browse files
reznikmmreznikmm
committed
Allow more complex sorting in LSP tests.
Extend `sortReply` to work with keys nested in objects inside JSON array. With this sort complex reply JSON to have more stable tests. For instance ```json "sortReply": {"result": {"range": {"start": "line"}}} ``` will sort `result` JSON array using `X.range.start.line` as a sorting key, where `X` is an array item. Allow integer JSON values as sorting keys also.
1 parent 00e7802 commit b93bd59

File tree

5 files changed

+100
-22
lines changed

5 files changed

+100
-22
lines changed

‎source/tester/tester-tests.adb‎

Lines changed: 89 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -519,6 +519,7 @@ package body Tester.Tests is
519519
procedure Sort_Reply_In_JSON
520520
(JSON : GNATCOLL.JSON.JSON_Value;
521521
Parameter : GNATCOLL.JSON.JSON_Value);
522+
-- Sort JSON inplace taking Parameter as sorting key(s) definition.
522523

523524
-----------
524525
-- Match --
@@ -694,9 +695,9 @@ package body Tester.Tests is
694695
procedure Sort_Reply
695696
(Name : String;
696697
Value : GNATCOLL.JSON.JSON_Value);
697-
-- Let Name be field name in the reply to be sorted, Value is
698-
-- JSON string with a key. Then JSON[Name] should be array.
699-
-- Each element in the array should have key field. Sort this array.
698+
-- Let Name be field name in the reply (JSON) to be sorted, Value is
699+
-- the rest of sorting key(s) definition. Then JSON[Name] should be
700+
-- array (if presents). Sort this array according to Value.
700701

701702
----------------
702703
-- Sort_Reply --
@@ -708,54 +709,108 @@ package body Tester.Tests is
708709
is
709710
function Less
710711
(Left, Right : GNATCOLL.JSON.JSON_Value) return Boolean;
712+
-- Compare two JSON values using key definition given in Value
711713

712714
function Less
713715
(Left, Right : GNATCOLL.JSON.JSON_Value) return Boolean
714716
is
715-
function Key_Count return Natural;
716-
function Get_Key (Index : Positive) return String;
717+
function Key_Count
718+
(Value : GNATCOLL.JSON.JSON_Value) return Natural;
719+
-- Count number of keys in given Value (keys definition)
720+
721+
function Get_Key_Value
722+
(Object : GNATCOLL.JSON.JSON_Value;
723+
Value : GNATCOLL.JSON.JSON_Value;
724+
Index : Positive) return GNATCOLL.JSON.JSON_Value;
725+
-- Object is a JSON object under inspection.
726+
-- Value is a key(s) definition.
727+
-- Index is a key number (for compound keys could be > 1).
728+
-- Return JSON value that corresponds to key definition.
717729

718730
---------------
719731
-- Key_Count --
720732
---------------
721733

722-
function Key_Count return Natural is
734+
function Key_Count
735+
(Value : GNATCOLL.JSON.JSON_Value) return Natural is
723736
begin
724737
case Value.Kind is
725738
when GNATCOLL.JSON.JSON_String_Type =>
726739
return 1;
727740
when GNATCOLL.JSON.JSON_Array_Type =>
728741
return GNATCOLL.JSON.Length (Value.Get);
742+
when GNATCOLL.JSON.JSON_Object_Type =>
743+
declare
744+
procedure On_Field
745+
(Ignore : UTF8_String; Value : JSON_Value);
746+
-- Fetch Value into Child variable
747+
748+
Child : GNATCOLL.JSON.JSON_Value;
749+
750+
procedure On_Field
751+
(Ignore : UTF8_String; Value : JSON_Value) is
752+
begin
753+
Child := Value;
754+
end On_Field;
755+
begin
756+
-- Just one field expected
757+
Value.Map_JSON_Object (On_Field'Access);
758+
return Key_Count (Child);
759+
end;
729760
when others =>
730761
raise Program_Error;
731762
end case;
732763
end Key_Count;
733764

734-
-------------
735-
-- Get_Key --
736-
-------------
765+
-------------------
766+
-- Get_Key_Value --
767+
-------------------
737768

738-
function Get_Key (Index : Positive) return String is
769+
function Get_Key_Value
770+
(Object : GNATCOLL.JSON.JSON_Value;
771+
Value : GNATCOLL.JSON.JSON_Value;
772+
Index : Positive) return GNATCOLL.JSON.JSON_Value is
739773
begin
740774
case Value.Kind is
741775
when GNATCOLL.JSON.JSON_String_Type =>
742-
return Value.Get;
776+
return Object.Get (Value.Get);
743777
when GNATCOLL.JSON.JSON_Array_Type =>
744-
return GNATCOLL.JSON.Get (Value.Get, Index).Get;
778+
return Object.Get
779+
(GNATCOLL.JSON.Get (Value.Get, Index).Get);
780+
when GNATCOLL.JSON.JSON_Object_Type =>
781+
declare
782+
procedure On_Field
783+
(Name : UTF8_String; Value : JSON_Value);
784+
-- Fetch Object[Name] into Child variable and
785+
-- Value into Child_Key variable.
786+
787+
Child : GNATCOLL.JSON.JSON_Value;
788+
Child_Key : GNATCOLL.JSON.JSON_Value;
789+
790+
procedure On_Field
791+
(Name : UTF8_String; Value : JSON_Value) is
792+
begin
793+
Child := Object.Get (Name);
794+
Child_Key := Value;
795+
end On_Field;
796+
begin
797+
-- Just one field expected
798+
Value.Map_JSON_Object (On_Field'Access);
799+
return Get_Key_Value (Child, Child_Key, Index);
800+
end;
745801
when others =>
746802
raise Program_Error;
747803
end case;
748-
end Get_Key;
804+
end Get_Key_Value;
749805

750806
begin
751-
for J in 1 .. Key_Count loop
807+
for J in 1 .. Key_Count (Value) loop
752808
declare
753-
Key : constant String := Get_Key (J);
754809
Left_Value : constant GNATCOLL.JSON.JSON_Value :=
755-
Left.Get (Key);
810+
Get_Key_Value (Left, Value, J);
756811

757812
Right_Value : constant GNATCOLL.JSON.JSON_Value :=
758-
Right.Get (Key);
813+
Get_Key_Value (Right, Value, J);
759814
begin
760815
if Left_Value.Kind /= Right_Value.Kind then
761816
return Left_Value.Kind < Right_Value.Kind;
@@ -772,6 +827,16 @@ package body Tester.Tests is
772827
end if;
773828
end;
774829

830+
when GNATCOLL.JSON.JSON_Int_Type =>
831+
declare
832+
L : constant Integer := Left_Value.Get;
833+
R : constant Integer := Right_Value.Get;
834+
begin
835+
if L /= R then
836+
return L < R;
837+
end if;
838+
end;
839+
775840
when others =>
776841
raise Program_Error with "Not implemented";
777842
end case;
@@ -788,11 +853,16 @@ package body Tester.Tests is
788853
end if;
789854

790855
List := JSON.Get (Name);
791-
if Value.Kind = GNATCOLL.JSON.JSON_Object_Type then
792-
Sort_Reply_In_JSON (List, Value);
856+
857+
if List.Kind = GNATCOLL.JSON.JSON_Null_Type then
858+
return; -- No such field, do nothing
793859
elsif List.Kind = GNATCOLL.JSON.JSON_Array_Type then
794860
GNATCOLL.JSON.Sort (List, Less'Access);
795861
JSON.Set_Field (Name, List);
862+
elsif Value.Kind = GNATCOLL.JSON.JSON_Object_Type then
863+
Sort_Reply_In_JSON (List, Value);
864+
else
865+
raise Program_Error;
796866
end if;
797867
end Sort_Reply;
798868

‎testsuite/ada_lsp/README.md‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -72,7 +72,7 @@ Property value - an object:
7272
* "wait" - array of _wait_ objects to expect them in any order.
7373
* "sortReply" - an object describing how to sort a server reply. Let's
7474
explain by examples:
75-
1. `"sortReply": {"result", "uri"}` - Server reply should have a property
75+
1. `"sortReply": {"result": "uri"}` - Server reply should have a property
7676
`result`, that is an array of objects, each of them has a property
7777
`uri`. Tester driver will sort the array using the `uri` as a sort key.
7878
2. `"sortReply": { "result": ["label", "detail"] }` - you can have a
@@ -84,6 +84,10 @@ Property value - an object:
8484
an object, that has a `items` property. Where `items` is an array of
8585
objects, that should be sorted using the `label` and `detail` as a
8686
composite sort key.
87+
4. `"sortReply": { "result": { "from": "uri" } }` - Server reply should
88+
have a property `result`, that is an array of objects. Array items
89+
have property `from` which is an object. Tester driver will sort the
90+
array using the `uri` property of `from` objects as a sort key.
8791
* "waitFactor" - see "Execution timeouts"
8892

8993
Where _wait_ object is expected server answer. Each property of this object

‎testsuite/ada_lsp/aggregate.is_called_by/test.json‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -332,6 +332,7 @@
332332
}
333333
}
334334
},
335+
"sortReply": {"result": {"from": "uri"}},
335336
"wait": [
336337
{
337338
"id": "ada-7",

‎testsuite/ada_lsp/show_dependencies.aggregate/test.json‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -172,6 +172,7 @@
172172
"id": 2,
173173
"method": "textDocument/alsShowDependencies"
174174
},
175+
"sortReply": {"result": "uri"},
175176
"wait": [
176177
{
177178
"id": 2,
@@ -181,11 +182,11 @@
181182
"projectUri": "$URI{}"
182183
},
183184
{
184-
"uri": "$URI{p/main.adb}",
185+
"uri": "$URI{common/common_pack.ads}",
185186
"projectUri": "$URI{}"
186187
},
187188
{
188-
"uri": "$URI{common/common_pack.ads}",
189+
"uri": "$URI{p/main.adb}",
189190
"projectUri": "$URI{}"
190191
},
191192
{

‎testsuite/ada_lsp/type_definition.aggregate/test.json‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -143,6 +143,7 @@
143143
"id": 2,
144144
"method": "textDocument/typeDefinition"
145145
},
146+
"sortReply": {"result": {"range": {"start": "line"}}},
146147
"wait": [
147148
{
148149
"id": 2,
@@ -195,6 +196,7 @@
195196
"id": 6,
196197
"method": "textDocument/typeDefinition"
197198
},
199+
"sortReply": {"result": {"range": {"start": "line"}}},
198200
"wait": [
199201
{
200202
"id": 6,

0 commit comments

Comments
 (0)