------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--                       ADA.STRINGS.TEXT_OUTPUT.UTILS                      --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 2020, Free Software Foundation, Inc.            --
--                                                                          --
-- GNAT 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.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Strings.UTF_Encoding.Wide_Wide_Strings;

package body Ada.Strings.Text_Output.Utils is

   procedure Put_Octet (S : in out Sink'Class; Item : Character) with Inline;
   --  Send a single octet to the current Chunk

   procedure Adjust_Column (S : in out Sink'Class) with Inline;
   --  Adjust the column for a non-NL character.

   procedure Put_UTF_8_Outline (S : in out Sink'Class; Item : UTF_8);
   --  Out-of-line portion of Put_UTF_8. This exists solely to make Put_UTF_8
   --  small enough to reasonably inline it.

   procedure Full (S : in out Sink'Class) is
   begin
      pragma Assert (S.Last = S.Chunk_Length);
      Full_Method (S);
      pragma Assert (S.Last = 0);
   end Full;

   procedure Flush (S : in out Sink'Class) is
   begin
      Flush_Method (S);
   end Flush;

   procedure Put_Octet (S : in out Sink'Class; Item : Character) is
   begin
      S.Last := @ + 1;
      S.Cur_Chunk.Chars (S.Last) := Item;
      pragma Assert (S.Chunk_Length = S.Cur_Chunk.Chars'Length);
      if S.Last = S.Chunk_Length then
         Full (S);
      end if;
   end Put_Octet;

   procedure Adjust_Column (S : in out Sink'Class) is
   begin
      --  If we're in the first column, indent. This is handled here, rather
      --  than when we see NL, because we don't want spaces in a blank line.
      --  The character we're about to put is not NL; NL is handled in
      --  New_Line. So after indenting, we simply increment the Column.

      if S.Column = 1 then
         Tab_To_Column (S, S.Indentation + 1);
      end if;
      S.Column := @ + 1;
   end Adjust_Column;

   procedure Put_7bit (S : in out Sink'Class; Item : Character_7) is
   begin
      Adjust_Column (S);
      Put_Octet (S, Item);
   end Put_7bit;

   procedure Put_7bit_NL (S : in out Sink'Class; Item : Character_7) is
   begin
      if Item = NL then
         New_Line (S);
      else
         Put_7bit (S, Item);
      end if;
   end Put_7bit_NL;

   procedure Put_Character (S : in out Sink'Class; Item : Character) is
   begin
      if Character'Pos (Item) < 2**7 then
         Put_7bit_NL (S, Item);
      else
         Put_Wide_Wide_Character (S, To_Wide_Wide (Item));
      end if;
   end Put_Character;

   procedure Put_Wide_Character
     (S : in out Sink'Class; Item : Wide_Character) is
   begin
      if Wide_Character'Pos (Item) < 2**7 then
         Put_7bit_NL (S, From_Wide (Item));
      else
         Put_Wide_Wide_Character (S, To_Wide_Wide (Item));
      end if;
   end Put_Wide_Character;

   procedure Put_Wide_Wide_Character
     (S : in out Sink'Class; Item : Wide_Wide_Character) is
   begin
      if Wide_Wide_Character'Pos (Item) < 2**7 then
         Put_7bit_NL (S, From_Wide_Wide (Item));
      else
         S.All_7_Bits := False;
         if Wide_Wide_Character'Pos (Item) >= 2**8 then
            S.All_8_Bits := False;
         end if;
         declare
            Temp : constant UTF_8_Lines :=
              UTF_Encoding.Wide_Wide_Strings.Encode ((1 => Item));
         begin
            for X of Temp loop
               pragma Assert (X /= NL);
               Adjust_Column (S);
               Put_Octet (S, X);
            end loop;
         end;
      end if;
   end Put_Wide_Wide_Character;

   procedure Put_UTF_8_Outline (S : in out Sink'Class; Item : UTF_8) is
   begin
      if S.Last + Item'Length = S.Chunk_Length then
         --  Item fits exactly in current chunk

         S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item;
         S.Last := S.Last + Item'Length;
         S.Column := S.Column + Item'Length;
         Full (S);
         --  ???Seems like maybe we shouldn't call Full until we have MORE
         --  characters. But then we can't pass Chunk_Length => 1 to
         --  Create_File to get unbuffered output.
      else
         --  We get here only if Item doesn't fit in the current chunk, which
         --  should be fairly rare. We split Item into Left and Right, where
         --  Left exactly fills the current chunk, and recurse on Left and
         --  Right. Right will fit into the next chunk unless it's very long,
         --  so another level of recursion will be extremely rare.

         declare
            Left_Length : constant Natural := S.Chunk_Length - S.Last;
            Right_First : constant Natural := Item'First + Left_Length;
            Left : UTF_8 renames Item (Item'First .. Right_First - 1);
            Right : UTF_8 renames Item (Right_First .. Item'Last);
            pragma Assert (Left & Right = Item);
         begin
            Put_UTF_8 (S, Left); -- This will call Full.
            Put_UTF_8 (S, Right); -- This might call Full, but probably not.
         end;
      end if;
   end Put_UTF_8_Outline;

   procedure Put_UTF_8 (S : in out Sink'Class; Item : UTF_8) is
   begin
      Adjust_Column (S);

      if S.Last + Item'Length < S.Chunk_Length then
         --  Item fits in current chunk

         S.Cur_Chunk.Chars (S.Last + 1 .. S.Last + Item'Length) := Item;
         S.Last := S.Last + Item'Length;
         S.Column := S.Column + Item'Length;
      else
         Put_UTF_8_Outline (S, Item);
      end if;
   end Put_UTF_8;

   procedure Put_UTF_8_Lines (S : in out Sink'Class; Item : UTF_8_Lines) is
      Line_Start, Index : Integer := Item'First;
      --  Needs to be Integer, because Item'First might be negative for empty
      --  Items.
   begin
      while Index <= Item'Last loop
         if Item (Index) = NL then
            if Index > Line_Start then
               Put_UTF_8 (S, Item (Line_Start .. Index - 1));
            end if;
            New_Line (S);
            Line_Start := Index + 1;
         end if;

         Index := @ + 1;
      end loop;

      if Index > Line_Start then
         Put_UTF_8 (S, Item (Line_Start .. Index - 1));
      end if;
   end Put_UTF_8_Lines;

   procedure Put_String (S : in out Sink'Class; Item : String) is
   begin
      for X of Item loop
         Put_Character (S, X);
      end loop;
   end Put_String;

   procedure Put_Wide_String (S : in out Sink'Class; Item : Wide_String) is
   begin
      for X of Item loop
         Put_Wide_Character (S, X);
      end loop;
   end Put_Wide_String;

   procedure Put_Wide_Wide_String
     (S : in out Sink'Class; Item : Wide_Wide_String) is
   begin
      for X of Item loop
         Put_Wide_Wide_Character (S, X);
      end loop;
   end Put_Wide_Wide_String;

   procedure New_Line (S : in out Sink'Class) is
   begin
      S.Column := 1;
      Put_Octet (S, NL);
   end New_Line;

   function Column (S : Sink'Class) return Positive is (S.Column);

   procedure Tab_To_Column (S : in out Sink'Class; Column : Positive) is
   begin
      if S.Column < Column then
         for X in 1 .. Column - S.Column loop
            Put_Octet (S, ' ');
         end loop;
         S.Column := Column;
      end if;
   end Tab_To_Column;

   procedure Set_Indentation (S : in out Sink'Class; Amount : Natural) is
   begin
      S.Indentation := Amount;
   end Set_Indentation;

   function Indentation (S : Sink'Class) return Natural is (S.Indentation);

   procedure Indent
     (S : in out Sink'Class; Amount : Optional_Indentation := Default)
   is
      By : constant Natural :=
        (if Amount = Default then S.Indent_Amount else Amount);
   begin
      Set_Indentation (S, Indentation (S) + By);
   end Indent;

   procedure Outdent
     (S : in out Sink'Class; Amount : Optional_Indentation := Default)
   is
      By : constant Natural :=
        (if Amount = Default then S.Indent_Amount else Amount);
   begin
      Set_Indentation (S, Indentation (S) - By);
   end Outdent;

end Ada.Strings.Text_Output.Utils;
