ada_language_server/source/codec_test/codec_test.adb

------------------------------------------------------------------------------
--                         Language Server Protocol                         --
--                                                                          --
--                     Copyright (C) 2018-2021, AdaCore                     --
--                                                                          --
-- This is free software;  you can redistribute it  and/or modify it  under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  This software is distributed in the hope  that it will be useful, --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
-- License for  more details.  You should have  received  a copy of the GNU --
-- General  Public  License  distributed  with  this  software;   see  file --
-- COPYING3.  If not, go to http://www.gnu.org/licenses for a complete copy --
-- of the license.                                                          --
------------------------------------------------------------------------------

with LSP.Messages;
with LSP.Messages.Client_Responses;
with LSP.Messages.Server_Responses;
with LSP.JSON_Streams;

with Ada.Command_Line;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Fixed;
with Ada.Strings.Hash;
with Ada.Text_IO;
with Ada.Streams.Stream_IO;

with GNATCOLL.JSON;

with VSS.Stream_Element_Vectors.Conversions;
with VSS.Text_Streams.Memory_UTF8_Input;
with VSS.Text_Streams.Memory_UTF8_Output;
with VSS.JSON.Pull_Readers.Simple;

procedure Codec_Test is

   type Test_Access is access function
     (Input : VSS.Stream_Element_Vectors.Stream_Element_Vector)
      return VSS.Stream_Element_Vectors.Stream_Element_Vector;
   --  A function that converts Input to an Ada type and then converts it back
   --  to Stream_Element_Buffer.

   procedure Process_File
     (File_Name : String;
      Type_Name : String);
   --  Process one test file. Read JSON from File_Name and deserialize it into
   --  an object of given type, then serialize it tab and compare with origin.
   --  It prints found differences and set failure exit status if test fails.

   function Read_File (File_Name : String)
      return VSS.Stream_Element_Vectors.Stream_Element_Vector;
   --  Read content of the file and return it as a string

   procedure Register_Tests;
   --  Register all known codec test in Test_Map

   function Compare (Input, Output : GNATCOLL.JSON.JSON_Value) return Boolean;
   --  Compare two JSONs and raise error is they differ

   generic
      type Response is new LSP.Messages.ResponseMessage with private;
   function Generic_Response_Test
     (Input : VSS.Stream_Element_Vectors.Stream_Element_Vector)
      return VSS.Stream_Element_Vectors.Stream_Element_Vector;
   --  Generic codec for a response.

   package Test_Maps is new Ada.Containers.Indefinite_Hashed_Maps
     (Key_Type        => String,
      Element_Type    => Test_Access,
      Hash            => Ada.Strings.Hash,
      Equivalent_Keys => "=");

   Test_Map : Test_Maps.Map;
   --  A map from Ada type name to corresponding codec test

   ---------------------------
   -- Generic_Response_Test --
   ---------------------------

   function Generic_Response_Test
     (Input : VSS.Stream_Element_Vectors.Stream_Element_Vector)
      return VSS.Stream_Element_Vectors.Stream_Element_Vector
   is
      Text_Input : aliased
        VSS.Text_Streams.Memory_UTF8_Input.Memory_UTF8_Input_Stream;
      Reader     : aliased
        VSS.JSON.Pull_Readers.Simple.JSON_Simple_Pull_Reader;
      In_JS      : aliased LSP.JSON_Streams.JSON_Stream (False, Reader'Access);
   begin
      Text_Input.Set_Data (Input);
      Reader.Set_Stream (Text_Input'Unchecked_Access);
      Reader.Read_Next;
      pragma Assert (Reader.Is_Start_Document);
      Reader.Read_Next;
      pragma Assert (Reader.Is_Start_Object);

      declare
         Out_JS : aliased LSP.JSON_Streams.JSON_Stream;
         Output : aliased
           VSS.Text_Streams.Memory_UTF8_Output.Memory_UTF8_Output_Stream;
         Object : Response (Is_Error => False);

      begin
         Out_JS.Set_Stream (Output'Unchecked_Access);
         Response'Read (In_JS'Access, Object);
         Response'Write (Out_JS'Access, Object);

         return Output.Buffer;
      end;
   end Generic_Response_Test;

   -------------
   -- Compare --
   -------------

   function Compare
     (Input, Output : GNATCOLL.JSON.JSON_Value) return Boolean
   is
      use type GNATCOLL.JSON.JSON_Value_Type;

      Fields_Match : Boolean := True;

      procedure Check_Input_Field
        (Field : String;
         Value : GNATCOLL.JSON.JSON_Value);

      procedure Check_Output_Field
        (Field : String;
         Value : GNATCOLL.JSON.JSON_Value);

      -----------------------
      -- Check_Input_Field --
      -----------------------

      procedure Check_Input_Field
        (Field : String;
         Value : GNATCOLL.JSON.JSON_Value) is
      begin
         if Output.Has_Field (Field) then
            if not Compare (Value, Output.Get (Field)) then
               Fields_Match := False;
               Ada.Text_IO.Put_Line ("Unmatched JSON field: " & Field);
            end if;
         else
            Ada.Text_IO.Put_Line ("No JSON field: " & Field);
         end if;
      end Check_Input_Field;

      ------------------------
      -- Check_Output_Field --
      ------------------------

      procedure Check_Output_Field
        (Field : String;
         Value : GNATCOLL.JSON.JSON_Value)
      is
         pragma Unreferenced (Value);
      begin
         if not Output.Has_Field (Field) then
            Ada.Text_IO.Put_Line ("Extra JSON field: " & Field);
         end if;
      end Check_Output_Field;

   begin
      if Input.Kind /= Output.Kind then
         Ada.Text_IO.Put_Line ("Unmatched JSON value kind");
         return False;
      end if;

      case Input.Kind is
         when GNATCOLL.JSON.JSON_Null_Type =>
            null;

         when GNATCOLL.JSON.JSON_Boolean_Type =>
            if Boolean'(Input.Get) /= Output.Get then
               Ada.Text_IO.Put_Line ("Unmatched JSON boolean value");
               return False;
            end if;

         when GNATCOLL.JSON.JSON_Int_Type =>
            if Integer'(Input.Get) /= Output.Get then
               Ada.Text_IO.Put_Line ("Unmatched JSON Integer value");
               return False;
            end if;

         when GNATCOLL.JSON.JSON_Float_Type =>
            if Float'(Input.Get) /= Output.Get then
               Ada.Text_IO.Put_Line ("Unmatched JSON Float value");
               return False;
            end if;

         when GNATCOLL.JSON.JSON_String_Type =>
            if String'(Input.Get) /= String'(Output.Get) then
               Ada.Text_IO.Put_Line ("Unmatched JSON String value");
               return False;
            end if;

         when GNATCOLL.JSON.JSON_Array_Type =>
            declare
               Left  : constant GNATCOLL.JSON.JSON_Array := Input.Get;
               Right : constant GNATCOLL.JSON.JSON_Array := Output.Get;
            begin
               if GNATCOLL.JSON.Length (Left) /=
                 GNATCOLL.JSON.Length (Right)
               then
                  Ada.Text_IO.Put_Line ("Unmatched JSON Array length");
                  return False;
               end if;

               for J in 1 .. GNATCOLL.JSON.Length (Left) loop
                  if not Compare
                    (GNATCOLL.JSON.Get (Left, J),
                     GNATCOLL.JSON.Get (Right, J))
                  then
                     Ada.Text_IO.Put_Line
                       ("Unmatched JSON Array element:" & J'Img);
                     return False;
                  end if;
               end loop;
            end;

         when GNATCOLL.JSON.JSON_Object_Type =>
            Input.Map_JSON_Object (Check_Input_Field'Access);
            Output.Map_JSON_Object (Check_Output_Field'Access);

            if not Fields_Match then
               Ada.Text_IO.Put_Line ("Unmatched JSON Object");
            end if;

            return Fields_Match;
      end case;

      return True;
   end Compare;

   ------------------
   -- Process_File --
   ------------------

   procedure Process_File
     (File_Name : String;
      Type_Name : String)
   is
      In_Buffer : constant VSS.Stream_Element_Vectors.Stream_Element_Vector
        := Read_File (File_Name);

      Out_Buffer : VSS.Stream_Element_Vectors.Stream_Element_Vector;
   begin
      Out_Buffer := Test_Map (Type_Name).all (In_Buffer);

      declare
         Input : constant GNATCOLL.JSON.JSON_Value :=
           GNATCOLL.JSON.Read
             (VSS.Stream_Element_Vectors.Conversions.Unchecked_To_String
                (In_Buffer),  File_Name);

         Output : constant GNATCOLL.JSON.JSON_Value :=
           GNATCOLL.JSON.Read
             (VSS.Stream_Element_Vectors.Conversions.Unchecked_To_String
                (Out_Buffer));
      begin
         if not Compare (Input, Output) then
            Ada.Text_IO.Put_Line
              ("Test FAILED: " & File_Name & " " & Type_Name);
            Ada.Text_IO.Put_Line (Output.Write);
            Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
         end if;
      end;
   end Process_File;

   ---------------
   -- Read_File --
   ---------------

   function Read_File (File_Name : String)
      return VSS.Stream_Element_Vectors.Stream_Element_Vector
   is
      use type Ada.Streams.Stream_Element_Count;

      Input  : Ada.Streams.Stream_IO.File_Type;
      Result : VSS.Stream_Element_Vectors.Stream_Element_Vector;
      Data   : Ada.Streams.Stream_Element_Array (1 .. 256);
      Last   : Ada.Streams.Stream_Element_Count;
   begin
      Ada.Streams.Stream_IO.Open
        (Input, Ada.Streams.Stream_IO.In_File, File_Name);

      loop
         Ada.Streams.Stream_IO.Read (Input, Data, Last);
         exit when Last = 0;

         for J of Data (1 .. Last) loop
            Result.Append (J);
         end loop;
      end loop;

      Ada.Streams.Stream_IO.Close (Input);

      return Result;
   end Read_File;

   function ApplyWorkspaceEdit_Response_Test is new Generic_Response_Test
       (LSP.Messages.Client_Responses.ApplyWorkspaceEdit_Response);

   function CodeAction_Response_Test is new Generic_Response_Test
     (LSP.Messages.Server_Responses.CodeAction_Response);

   function Completion_Response_Test is new Generic_Response_Test
     (LSP.Messages.Server_Responses.Completion_Response);

   function Highlight_Response_Test is new Generic_Response_Test
     (LSP.Messages.Server_Responses.Highlight_Response);

   function Hover_Response_Test is
     new Generic_Response_Test (LSP.Messages.Server_Responses.Hover_Response);

   function Initialize_Response_Test is new Generic_Response_Test
     (LSP.Messages.Server_Responses.Initialize_Response);

   function Location_Response_Test is new Generic_Response_Test
     (LSP.Messages.Server_Responses.Location_Response);

   function SignatureHelp_Response_Test is new Generic_Response_Test
     (LSP.Messages.Server_Responses.SignatureHelp_Response);

   function Symbol_Response_Test is new Generic_Response_Test
     (LSP.Messages.Server_Responses.Symbol_Response);

   --------------------
   -- Register_Tests --
   --------------------

   procedure Register_Tests is
   begin
      Test_Map.Insert
        ("ApplyWorkspaceEdit_Response",
         ApplyWorkspaceEdit_Response_Test'Access);
      Test_Map.Insert ("CodeAction_Response", CodeAction_Response_Test'Access);
      Test_Map.Insert ("Completion_Response", Completion_Response_Test'Access);
      Test_Map.Insert ("Highlight_Response", Highlight_Response_Test'Access);
      Test_Map.Insert ("Hover_Response", Hover_Response_Test'Access);
      Test_Map.Insert ("Initialize_Response", Initialize_Response_Test'Access);
      Test_Map.Insert ("Location_Response", Location_Response_Test'Access);
      Test_Map.Insert
        ("SignatureHelp_Response", SignatureHelp_Response_Test'Access);
      Test_Map.Insert ("Symbol_Response", Symbol_Response_Test'Access);
   end Register_Tests;

begin
   Register_Tests;

   while not Ada.Text_IO.End_Of_File loop
      declare
         Line  : constant String := Ada.Text_IO.Get_Line;
         Space : constant Natural := Ada.Strings.Fixed.Index (Line, " ");
      begin
         if Line'Length > 0 and then Line (1) /= '#' then
            Process_File
              (File_Name => Line (1 .. Space - 1),
               Type_Name => Line (Space + 1 .. Line'Last));
         end if;
      end;
   end loop;
end Codec_Test;