vss_24.0.0_b4d0be7c/source/json/implementation/vss-json-push_writers.adb

--
--  Copyright (C) 2020-2021, AdaCore
--
--  SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
--

with Ada.Assertions;

with VSS.Characters;
with VSS.Implementation.Strings;
with VSS.Implementation.String_Handlers;
with VSS.Strings.Internals;
with VSS.Unicode;

package body VSS.JSON.Push_Writers is

   use type VSS.Text_Streams.Output_Text_Stream_Access;

   procedure Check_Effective_Stream
     (Self : in out JSON_Simple_Push_Writer'Class; Success : in out Boolean);

   procedure Escaped_String_Value
     (Self    : in out JSON_Simple_Push_Writer'Class;
      Item    : VSS.Strings.Virtual_String'Class;
      Success : in out Boolean);
   --  Outputs escaped string value

   -------------------
   -- Boolean_Value --
   -------------------

   overriding procedure Boolean_Value
     (Self    : in out JSON_Simple_Push_Writer;
      Value   : Boolean;
      Success : in out Boolean) is
   begin
      Self.Check_Effective_Stream (Success);

      if not Success then
         return;
      end if;

      if not Self.Open_Parenthesis then
         Self.Effective_Stream.Put (',', Success);

         if not Success then
            return;
         end if;

      else
         Self.Open_Parenthesis := False;
      end if;

      if Value then
         Self.Effective_Stream.Put ('t', Success);

         if not Success then
            return;
         end if;

         Self.Effective_Stream.Put ('r', Success);

         if not Success then
            return;
         end if;

         Self.Effective_Stream.Put ('u', Success);

         if not Success then
            return;
         end if;

         Self.Effective_Stream.Put ('e', Success);

         if not Success then
            return;
         end if;

      else
         Self.Effective_Stream.Put ('f', Success);

         if not Success then
            return;
         end if;

         Self.Effective_Stream.Put ('a', Success);

         if not Success then
            return;
         end if;

         Self.Effective_Stream.Put ('l', Success);

         if not Success then
            return;
         end if;

         Self.Effective_Stream.Put ('s', Success);

         if not Success then
            return;
         end if;

         Self.Effective_Stream.Put ('e', Success);

         if not Success then
            return;
         end if;
      end if;
   end Boolean_Value;

   ----------------------------
   -- Check_Effective_Stream --
   ----------------------------

   procedure Check_Effective_Stream
     (Self : in out JSON_Simple_Push_Writer'Class; Success : in out Boolean) is
   begin
      if Self.Effective_Stream = null then
         Success := False;
      end if;
   end Check_Effective_Stream;

   ---------------
   -- End_Array --
   ---------------

   overriding procedure End_Array
     (Self : in out JSON_Simple_Push_Writer; Success : in out Boolean) is
   begin
      Self.Check_Effective_Stream (Success);

      if not Success then
         return;
      end if;

      Self.Effective_Stream.Put (']', Success);

      if not Success then
         return;
      end if;

      Self.Open_Parenthesis := False;
   end End_Array;

   ------------------
   -- End_Document --
   ------------------

   overriding procedure End_Document
     (Self : in out JSON_Simple_Push_Writer; Success : in out Boolean) is
   begin
      --  End_Document is special exception: it must shutdown processing even
      --  in case of intermediate failures.

      declare
         Aux : Boolean := True;

      begin
         Self.Check_Effective_Stream (Aux);

         if not Aux then
            Success := False;

            return;
         end if;
      end;

      Self.Effective_Stream := null;
   end End_Document;

   ----------------
   -- End_Object --
   ----------------

   overriding procedure End_Object
     (Self : in out JSON_Simple_Push_Writer; Success : in out Boolean) is
   begin
      Self.Check_Effective_Stream (Success);

      if not Success then
         return;
      end if;

      Self.Effective_Stream.Put ('}', Success);

      if not Success then
         return;
      end if;

      Self.Open_Parenthesis := False;
   end End_Object;

   -------------------
   -- Error_Message --
   -------------------

   overriding function Error_Message
     (Self : JSON_Simple_Push_Writer) return VSS.Strings.Virtual_String is
   begin
      return VSS.Strings.Empty_Virtual_String;
   end Error_Message;

   --------------------------
   -- Escaped_String_Value --
   --------------------------

   procedure Escaped_String_Value
     (Self    : in out JSON_Simple_Push_Writer'Class;
      Item    : VSS.Strings.Virtual_String'Class;
      Success : in out Boolean)
   is
      procedure Escaped_Control_Character (Item : VSS.Unicode.Code_Point);
      --  Outputs escape sequence for given control character using hex format

      function Hex_Digit
        (C : VSS.Unicode.Code_Point) return VSS.Characters.Virtual_Character;
      --  Returns hexadecimal digit for given code point.

      -------------------------------
      -- Escaped_Control_Character --
      -------------------------------

      procedure Escaped_Control_Character (Item : VSS.Unicode.Code_Point) is
         use type VSS.Unicode.Code_Point;

         D4 : constant VSS.Unicode.Code_Point := Item and 16#00_000F#;
         D3 : constant VSS.Unicode.Code_Point :=
           (Item / 16#00_0010#) and 16#00_000F#;
         D2 : constant VSS.Unicode.Code_Point :=
           (Item / 16#00_0100#) and 16#00_000F#;
         D1 : constant VSS.Unicode.Code_Point :=
           (Item / 16#00_1000#) and 16#00_000F#;

      begin
         Self.Effective_Stream.Put ('\', Success);

         if not Success then
            return;
         end if;

         Self.Effective_Stream.Put ('u', Success);

         if not Success then
            return;
         end if;

         Self.Effective_Stream.Put (Hex_Digit (D1), Success);

         if not Success then
            return;
         end if;

         Self.Effective_Stream.Put (Hex_Digit (D2), Success);

         if not Success then
            return;
         end if;

         Self.Effective_Stream.Put (Hex_Digit (D3), Success);

         if not Success then
            return;
         end if;

         Self.Effective_Stream.Put (Hex_Digit (D4), Success);

         if not Success then
            return;
         end if;
      end Escaped_Control_Character;

      ---------------
      -- Hex_Digit --
      ---------------

      function Hex_Digit
        (C : VSS.Unicode.Code_Point) return VSS.Characters.Virtual_Character
      is
         use type VSS.Unicode.Code_Point;

      begin
         case C is
            when 16#0# .. 16#9# =>
               return VSS.Characters.Virtual_Character'Val (16#30# + C);

            when 16#A# .. 16#F# =>
               return VSS.Characters.Virtual_Character'Val (16#41# + C - 10);

            when others =>
               raise Ada.Assertions.Assertion_Error;
         end case;
      end Hex_Digit;

   begin
      Self.Effective_Stream.Put ('"', Success);

      if not Success then
         return;
      end if;

      if not Item.Is_Empty then
         --  Code block below use direct access to the internal string API to
         --  improve performance, check for empty string case was done above,
         --  thus check for null handler is not necessary here.

         declare
            Data     : VSS.Implementation.Strings.String_Data
              renames VSS.Strings.Internals.Data_Access_Constant (Item).all;
            Handler  : constant not null
              VSS.Implementation.Strings.String_Handler_Access :=
                VSS.Implementation.Strings.Handler (Data);
            Position : VSS.Implementation.Strings.Cursor;
            Code     : VSS.Unicode.Code_Point;

         begin
            Handler.Before_First_Character (Data, Position);

            while Handler.Forward (Data, Position) loop
               Code := Handler.Element (Data, Position);

               case Code is
                  when 16#00_0000# .. 16#00_0007#
                     | 16#00_000B#
                     | 16#00_000E# .. 16#00_001F#
                  =>
                     Escaped_Control_Character (Code);

                     if not Success then
                        return;
                     end if;

                  when 16#00_0008# =>
                     --  Escape backspace

                     Self.Effective_Stream.Put ('\', Success);

                     if not Success then
                        return;
                     end if;

                     Self.Effective_Stream.Put ('b', Success);

                     if not Success then
                        return;
                     end if;

                  when 16#00_0009# =>
                     --  Escape character tabulation

                     Self.Effective_Stream.Put ('\', Success);

                     if not Success then
                        return;
                     end if;

                     Self.Effective_Stream.Put ('t', Success);

                     if not Success then
                        return;
                     end if;

                  when 16#00_000A# =>
                     --  Escape line feed

                     Self.Effective_Stream.Put ('\', Success);

                     if not Success then
                        return;
                     end if;

                     Self.Effective_Stream.Put ('n', Success);

                     if not Success then
                        return;
                     end if;

                  when 16#00_000C# =>
                     --  Escape form feed

                     Self.Effective_Stream.Put ('\', Success);

                     if not Success then
                        return;
                     end if;

                     Self.Effective_Stream.Put ('f', Success);

                     if not Success then
                        return;
                     end if;

                  when 16#00_000D# =>
                     --  Escape carriage return

                     Self.Effective_Stream.Put ('\', Success);

                     if not Success then
                        return;
                     end if;

                     Self.Effective_Stream.Put ('r', Success);

                     if not Success then
                        return;
                     end if;

                  when Wide_Wide_Character'Pos ('"') =>
                     --  Escape double quotation mark

                     Self.Effective_Stream.Put ('\', Success);

                     if not Success then
                        return;
                     end if;

                     Self.Effective_Stream.Put ('"', Success);

                     if not Success then
                        return;
                     end if;

                  when Wide_Wide_Character'Pos ('\') =>
                     --  Escape reverse solidus

                     Self.Effective_Stream.Put ('\', Success);

                     if not Success then
                        return;
                     end if;

                     Self.Effective_Stream.Put ('\', Success);

                     if not Success then
                        return;
                     end if;

                  when others =>
                     Self.Effective_Stream.Put
                       (VSS.Characters.Virtual_Character'Val (Code), Success);

                     if not Success then
                        return;
                     end if;
               end case;
            end loop;
         end;
      end if;

      Self.Effective_Stream.Put ('"', Success);

      if not Success then
         return;
      end if;
   end Escaped_String_Value;

   --------------
   -- Key_Name --
   --------------

   overriding procedure Key_Name
     (Self    : in out JSON_Simple_Push_Writer;
      Name    : VSS.Strings.Virtual_String'Class;
      Success : in out Boolean) is
   begin
      Self.Check_Effective_Stream (Success);

      if not Success then
         return;
      end if;

      if not Self.Open_Parenthesis then
         Self.Effective_Stream.Put (',', Success);

         if not Success then
            return;
         end if;
      end if;

      if Name.Is_Empty then
         Success := False;

         return;
      end if;

      Self.Escaped_String_Value (Name, Success);

      if not Success then
         return;
      end if;

      Self.Effective_Stream.Put (':', Success);

      if not Success then
         return;
      end if;

      Self.Open_Parenthesis := True;
   end Key_Name;

   ----------------
   -- Null_Value --
   ----------------

   overriding procedure Null_Value
     (Self : in out JSON_Simple_Push_Writer; Success : in out Boolean) is
   begin
      Self.Check_Effective_Stream (Success);

      if not Success then
         return;
      end if;

      if not Self.Open_Parenthesis then
         Self.Effective_Stream.Put (',', Success);

         if not Success then
            return;
         end if;

      else
         Self.Open_Parenthesis := False;
      end if;

      Self.Effective_Stream.Put ('n', Success);

      if not Success then
         return;
      end if;

      Self.Effective_Stream.Put ('u', Success);

      if not Success then
         return;
      end if;

      Self.Effective_Stream.Put ('l', Success);

      if not Success then
         return;
      end if;

      Self.Effective_Stream.Put ('l', Success);

      if not Success then
         return;
      end if;
   end Null_Value;

   ------------------
   -- Number_Value --
   ------------------

   overriding procedure Number_Value
     (Self    : in out JSON_Simple_Push_Writer;
      Value   : VSS.JSON.JSON_Number;
      Success : in out Boolean) is
   begin
      Self.Check_Effective_Stream (Success);

      if not Success then
         return;
      end if;

      if not Self.Open_Parenthesis then
         Self.Effective_Stream.Put (',', Success);

         if not Success then
            return;
         end if;

      else
         Self.Open_Parenthesis := False;
      end if;

      case Value.Kind is
         when VSS.JSON.None =>
            raise Program_Error;

         when VSS.JSON.JSON_Integer =>
            declare
               Image : constant Wide_Wide_String :=
                 Interfaces.Integer_64'Wide_Wide_Image (Value.Integer_Value);

            begin
               for C of Image loop
                  if C /= ' ' then
                     Self.Effective_Stream.Put
                       (VSS.Characters.Virtual_Character (C), Success);

                     if not Success then
                        return;
                     end if;
                  end if;
               end loop;
            end;

         when VSS.JSON.JSON_Float =>
            declare
               Image : constant Wide_Wide_String :=
                 Interfaces.IEEE_Float_64'Wide_Wide_Image (Value.Float_Value);

            begin
               for C of Image loop
                  if C /= ' ' then
                     Self.Effective_Stream.Put
                       (VSS.Characters.Virtual_Character (C), Success);

                     if not Success then
                        return;
                     end if;
                  end if;
               end loop;
            end;

         when VSS.JSON.Out_Of_Range =>
            --  ??? Not implemented. Note, image must be checked for validity
            --  first.

            raise Program_Error;
      end case;
   end Number_Value;

   ----------------
   -- Set_Stream --
   ----------------

   procedure Set_Stream
     (Self   : in out JSON_Simple_Push_Writer'Class;
      Stream : not null VSS.Text_Streams.Output_Text_Stream_Access) is
   begin
      Self.Configured_Stream := Stream;
   end Set_Stream;

   -----------------
   -- Start_Array --
   -----------------

   overriding procedure Start_Array
     (Self : in out JSON_Simple_Push_Writer; Success : in out Boolean) is
   begin
      Self.Check_Effective_Stream (Success);

      if not Success then
         return;
      end if;

      if not Self.Open_Parenthesis then
         Self.Effective_Stream.Put (',', Success);

         if not Success then
            return;
         end if;
      end if;

      Self.Effective_Stream.Put ('[', Success);

      if not Success then
         return;
      end if;

      Self.Open_Parenthesis := True;
   end Start_Array;

   --------------------
   -- Start_Document --
   --------------------

   overriding procedure Start_Document
     (Self : in out JSON_Simple_Push_Writer; Success : in out Boolean) is
   begin
      if Self.Effective_Stream /= null then
         Success := False;

      elsif Self.Configured_Stream = null then
         Success := False;

      else
         Self.Effective_Stream := Self.Configured_Stream;
         Self.Open_Parenthesis := True;
      end if;
   end Start_Document;

   ------------------
   -- Start_Object --
   ------------------

   overriding procedure Start_Object
     (Self : in out JSON_Simple_Push_Writer; Success : in out Boolean) is
   begin
      Self.Check_Effective_Stream (Success);

      if not Success then
         return;
      end if;

      if not Self.Open_Parenthesis then
         Self.Effective_Stream.Put (',', Success);

         if not Success then
            return;
         end if;
      end if;

      Self.Effective_Stream.Put ('{', Success);

      if not Success then
         return;
      end if;

      Self.Open_Parenthesis := True;
   end Start_Object;

   ------------------
   -- String_Value --
   ------------------

   overriding procedure String_Value
     (Self    : in out JSON_Simple_Push_Writer;
      Value   : VSS.Strings.Virtual_String'Class;
      Success : in out Boolean) is
   begin
      Self.Check_Effective_Stream (Success);

      if not Success then
         return;
      end if;

      if not Self.Open_Parenthesis then
         Self.Effective_Stream.Put (',', Success);

         if not Success then
            return;
         end if;

      else
         Self.Open_Parenthesis := False;
      end if;

      Self.Escaped_String_Value (Value, Success);

      if not Success then
         return;
      end if;
   end String_Value;

end VSS.JSON.Push_Writers;