Natools

------------------------------------------------------------------------------
-- Copyright (c) 2013-2014, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

package body Natools.S_Expressions.Printers.Pretty is

   function Fit_In_Line
     (Output : in Printer;
      Width  : in Screen_Offset)
      return Boolean;
      --  Return whether Width can fit in the current line of Output

   function Indent_Width (Output : in Printer) return Screen_Offset;
      --  Return current indentation width on screen

   function Is_Extended_Token (Data : in Atom) return Boolean;
      --  Check whether Atom can be parsed by Natools.S_Expressions.Parsers
      --  when encoded as a token.

   function Is_Standard_Token (Data : in Atom) return Boolean;
      --  Check whether Atom can be encoded as a token according to Standard

   function Is_Newline
     (Data : in Atom;
      Position : in Offset;
      Encoding : in Newline_Encoding)
      return Boolean;
      --  Check whether Data contains a newline at Position

   procedure Newline (Output : in out Printer);
      --  Output a newline and indentation

   procedure Quoted_Lengths
     (Data        : in Atom;
      Encoding    : in Character_Encoding;
      Width       : in Screen_Offset;
      Newline     : in Newline_Encoding;
      Single_Line : in Boolean;
      Size        : out Count;
      Cursor      : in out Screen_Offset);
      --  Dry run of quoted-string encoding of Data, to measure the output
      --  length and the final position of the screen cursor.

   function Multi_Line_Quoted_Size
     (Output : in Printer;
      Data   : in Atom)
      return Count;
      --  Return how much octets a multi-line encoding of Data in Output
      --  would take.

   function Single_Line_Quoted_Size
     (Data     : in Atom;
      Encoding : in Character_Encoding)
      return Count;
   pragma Unreferenced (Single_Line_Quoted_Size);
      --  Return how much octets a single line encoding of Data would take

   function Single_Line_Quoted_Width
     (Data     : in Atom;
      Encoding : in Character_Encoding)
      return Screen_Offset;
      --  Return how much screen space a single line encoding of Data takes

   function UTF_Character_Size (Data : in Atom; Position : in Offset)
      return Count;
      --  Return how much octets spans the UTF-8 character at Position
      --  in Data, or 0 when it's an invalid UTF-8 sequence.

   procedure Write_Base64 (Output : in out Printer; Data : in Atom);
      --  Output base-64 encoding of Data

   procedure Write_Hex (Output : in out Printer; Data : in Atom);
      --  Output hexadecimal encoding of Data

   procedure Write_Quoted
     (Output : in out Printer;
      Data : in Atom;
      Single_Line : in Boolean);
      --  Output quoted-string encoding of Data

   procedure Write_Verbatim (Output : in out Printer; Data : in Atom);
      --  Output verbatim encoding of Data



   ------------------------
   -- Helper Subprograms --
   ------------------------

   function Fit_In_Line
     (Output : in Printer;
      Width  : in Screen_Offset)
      return Boolean is
   begin
      return Output.Param.Width = 0
        or Output.Param.Width >= Output.Cursor + Width;
   end Fit_In_Line;


   function Indent_Width (Output : in Printer) return Screen_Offset is
   begin
      if Output.Indent_Level > 0 and Output.Param.Indentation > 0 then
         case Output.Param.Indent is
            when Spaces | Tabs_And_Spaces =>
               return Output.Param.Indentation * Output.Indent_Level;
            when Tabs =>
               return Output.Param.Indentation * Output.Indent_Level
                 * Output.Param.Tab_Stop;
         end case;
      else
         return 0;
      end if;
   end Indent_Width;


   function Is_Extended_Token (Data : in Atom) return Boolean is
   begin
      for I in Data'Range loop
         case Data (I) is
            when 0 | Encodings.Space | Encodings.HT | Encodings.VT
                   | Encodings.LF | Encodings.CR | Encodings.FF
                   | Encodings.List_Begin | Encodings.List_End =>
               return False;
            when others => null;
         end case;
      end loop;

      return Data'Length > 0;
   end Is_Extended_Token;


   function Is_Standard_Token (Data : in Atom) return Boolean is
   begin
      if Data'Length = 0
        or else Data (Data'First) in Encodings.Digit_0 .. Encodings.Digit_9
      then
         return False;
      end if;

      for I in Data'Range loop
         case Data (I) is
            when Encodings.Upper_A .. Encodings.Upper_Z
              | Encodings.Lower_A .. Encodings.Lower_Z
              | Encodings.Digit_0 .. Encodings.Digit_9
              | Character'Pos ('-')
              | Character'Pos ('.')
              | Character'Pos ('/')
              | Character'Pos ('_')
              | Character'Pos (':')
              | Character'Pos ('*')
              | Character'Pos ('+')
              | Character'Pos ('=') =>
               null;
            when others => return False;
         end case;
      end loop;

      return True;
   end Is_Standard_Token;


   function UTF_Character_Size (Data : in Atom; Position : in Offset)
      return Count is
   begin
      case Data (Position) is
         when 2#0000_0000# .. 2#0111_1111# =>
            return 1;
         when 2#1000_0000# .. 2#1011_1111# =>
            return 0;
         when 2#1100_0000# .. 2#1101_1111# =>
            if Position + 1 in Data'Range
              and then Data (Position + 1) in 2#1000_0000# .. 2#1011_1111#
            then
               return 2;
            else
               return 0;
            end if;
         when 2#1110_0000# .. 2#1110_1111# =>
            if Position + 2 in Data'Range
              and then Data (Position + 1) in 2#1000_0000# .. 2#1011_1111#
              and then Data (Position + 2) in 2#1000_0000# .. 2#1011_1111#
            then
               return 3;
            else
               return 0;
            end if;
         when 2#1111_0000# .. 2#1111_0111# =>
            if Position + 3 in Data'Range
              and then Data (Position + 1) in 2#1000_0000# .. 2#1011_1111#
              and then Data (Position + 2) in 2#1000_0000# .. 2#1011_1111#
              and then Data (Position + 3) in 2#1000_0000# .. 2#1011_1111#
            then
               return 4;
            else
               return 0;
            end if;
         when 2#1111_1000# .. 2#1111_1011# =>
            if Position + 4 in Data'Range
              and then Data (Position + 1) in 2#1000_0000# .. 2#1011_1111#
              and then Data (Position + 2) in 2#1000_0000# .. 2#1011_1111#
              and then Data (Position + 3) in 2#1000_0000# .. 2#1011_1111#
              and then Data (Position + 4) in 2#1000_0000# .. 2#1011_1111#
            then
               return 5;
            else
               return 0;
            end if;
         when 2#1111_1100# .. 2#1111_1101# =>
            if Position + 5 in Data'Range
              and then Data (Position + 1) in 2#1000_0000# .. 2#1011_1111#
              and then Data (Position + 2) in 2#1000_0000# .. 2#1011_1111#
              and then Data (Position + 3) in 2#1000_0000# .. 2#1011_1111#
              and then Data (Position + 4) in 2#1000_0000# .. 2#1011_1111#
              and then Data (Position + 5) in 2#1000_0000# .. 2#1011_1111#
            then
               return 6;
            else
               return 0;
            end if;
         when 2#1111_1110# .. 2#1111_1111# =>
            return 0;
      end case;
   end UTF_Character_Size;


   function Is_Newline
     (Data : in Atom;
      Position : in Offset;
      Encoding : in Newline_Encoding)
      return Boolean is
   begin
      case Encoding is
         when CR =>
            return Data (Position) = Encodings.CR;
         when LF =>
            return Data (Position) = Encodings.LF;
         when CR_LF =>
            return Position + 1 in Data'Range
              and then Data (Position) = Encodings.CR
              and then Data (Position + 1) = Encodings.LF;
         when LF_CR =>
            return Position + 1 in Data'Range
              and then Data (Position) = Encodings.LF
              and then Data (Position + 1) = Encodings.CR;
      end case;
   end Is_Newline;


   procedure Newline (Output : in out Printer) is
      Data : Atom (0 .. 1);
      Length : Count;
   begin
      case Output.Param.Newline is
         when CR =>
            Data (0) := Encodings.CR;
            Length := 1;
         when LF =>
            Data (0) := Encodings.LF;
            Length := 1;
         when CR_LF =>
            Data (0) := Encodings.CR;
            Data (1) := Encodings.LF;
            Length := 2;
         when LF_CR =>
            Data (0) := Encodings.LF;
            Data (1) := Encodings.CR;
            Length := 2;
      end case;
      Output.Stream.Write (Data (0 .. Length - 1));

      if Output.Indent_Level > 0 and Output.Param.Indentation > 0 then
         case Output.Param.Indent is
            when Spaces =>
               Output.Cursor := Output.Param.Indentation * Output.Indent_Level
                                + 1;
               Output.Stream.Write ((1 .. Count (Output.Cursor) - 1
                                     => Encodings.Space));
            when Tabs =>
               Output.Cursor := Output.Param.Indentation * Output.Indent_Level;
               Output.Stream.Write ((1 .. Count (Output.Cursor)
                                     => Encodings.HT));
               Output.Cursor := Output.Cursor * Output.Param.Tab_Stop;
            when Tabs_And_Spaces =>
               Output.Cursor := Output.Param.Indentation * Output.Indent_Level
                                + 1;
               declare
                  Tab_Count : constant Count
                    := (Count (Output.Cursor) - 1)
                        / Count (Output.Param.Tab_Stop);
                  Space_Count : constant Count
                    := (Count (Output.Cursor) - 1)
                        mod Count (Output.Param.Tab_Stop);
               begin
                  Output.Stream.Write ((1 .. Tab_Count => Encodings.HT));
                  Output.Stream.Write ((1 .. Space_Count => Encodings.Space));
               end;
         end case;
      else
         Output.Cursor := 1;
      end if;
   end Newline;


   procedure Quoted_Lengths
     (Data        : in Atom;
      Encoding    : in Character_Encoding;
      Width       : in Screen_Offset;
      Newline     : in Newline_Encoding;
      Single_Line : in Boolean;
      Size        : out Count;
      Cursor      : in out Screen_Offset)
   is
      C : Count;
      I : Offset := Data'First;
      Last_Non_NL : Offset := Data'Last;
   begin
      while Last_Non_NL in Data'Range
        and then (Data (Last_Non_NL) = Encodings.CR
                  or Data (Last_Non_NL) = Encodings.LF)
      loop
         Last_Non_NL := Last_Non_NL - 1;
      end loop;

      Size := 2;
      Cursor := Cursor + 1;
      while I in Data'Range loop
         case Data (I) is
            when 8 | 9 | 11 | 12
              | Encodings.Quoted_Atom_End | Encodings.Escape =>
               Size := Size + 2;
               Cursor := Cursor + 2;
            when 10 | 13 =>
               if Single_Line
                 or else I > Last_Non_NL
                 or else not Is_Newline (Data, I, Newline)
               then
                  Size := Size + 2;
                  Cursor := Cursor + 2;
               else
                  Size := Size + 1;
                  Cursor := 1;
               end if;
            when 0 .. 7 | 14 .. 31 =>
               Size := Size + 4;
               Cursor := Cursor + 4;
            when 16#80# .. 16#FF# =>
               case Encoding is
                  when ASCII =>
                     Size := Size + 4;
                     Cursor := Cursor + 4;
                  when Latin =>
                     if Data (I) in 16#80# .. 16#9F# then
                        Size := Size + 4;
                        Cursor := Cursor + 4;
                     else
                        Size := Size + 1;
                        Cursor := Cursor + 1;
                     end if;
                  when UTF_8 =>
                     C := UTF_Character_Size (Data, I);
                     if C = 0 then
                        Size := Size + 4;
                        Cursor := Cursor + 4;
                     else
                        Size := Size + C;
                        Cursor := Cursor + 1;
                        I := I + C - 1;
                     end if;
               end case;
            when others =>
               Size := Size + 1;
               Cursor := Cursor + 1;
         end case;

         if not Single_Line
           and then Width > 0
           and then Cursor >= Width
         then
            case Newline is
               when CR | LF =>
                  Size := Size + 2;
               when CR_LF | LF_CR =>
                  Size := Size + 3;
            end case;
            Cursor := 1;
         end if;

         I := I + 1;
      end loop;

      Cursor := Cursor + 1;
   end Quoted_Lengths;


   function Multi_Line_Quoted_Size
     (Output : in Printer;
      Data   : in Atom)
      return Count
   is
      Discarded_Cursor : Screen_Offset := Output.Cursor;
      Result : Count;
   begin
      Quoted_Lengths
        (Data,
         Output.Param.Char_Encoding,
         Output.Param.Width,
         Output.Param.Newline,
         False,
         Result,
         Discarded_Cursor);
      return Result;
   end Multi_Line_Quoted_Size;


   function Single_Line_Quoted_Size
     (Data     : in Atom;
      Encoding : in Character_Encoding)
      return Count
   is
      Discarded : Screen_Offset := 0;
      Result : Count;
   begin
      Quoted_Lengths
        (Data, Encoding,
         0, CR, True,
         Result, Discarded);
      return Result;
   end Single_Line_Quoted_Size;


   function Single_Line_Quoted_Width
     (Data     : in Atom;
      Encoding : in Character_Encoding)
      return Screen_Offset
   is
      Result : Screen_Offset := 0;
      Discarded : Count;
   begin
      Quoted_Lengths
        (Data, Encoding,
         0, CR, True,
         Discarded, Result);
      return Result;
   end Single_Line_Quoted_Width;


   procedure Write_Base64 (Output : in out Printer; Data : in Atom) is
      Available : Screen_Offset;
      I : Offset := Data'First;
      Chunk_Size : Count;
   begin
      if Output.Param.Width = 0 then
         Output.Stream.Write ((0 => Encodings.Base64_Atom_Begin));
         Output.Stream.Write (Encodings.Encode_Base64 (Data));
         Output.Stream.Write ((0 => Encodings.Base64_Atom_End));
      else
         Output.Stream.Write ((0 => Encodings.Base64_Atom_Begin));
         Output.Cursor := Output.Cursor + 1;

         loop
            Available := Output.Param.Width - Output.Cursor;
            Chunk_Size := Count (Available) / 4 * 3;

            if Available mod 4 /= 0 then
               Output.Stream.Write ((0 => Encodings.Space));
               Output.Cursor := Output.Cursor + 1;
            end if;

            if I + Chunk_Size in Data'Range then
               Output.Stream.Write (Encodings.Encode_Base64
                                      (Data (I .. I + Chunk_Size - 1)));
               Newline (Output);
               I := I + Chunk_Size;
            else
               Output.Stream.Write (Encodings.Encode_Base64
                                      (Data (I .. Data'Last)));
               Output.Stream.Write ((0 => Encodings.Base64_Atom_End));
               Output.Cursor := Output.Cursor
                 + Screen_Offset (Data'Last - I + 2) / 3 * 4 + 1;
               exit;
            end if;
         end loop;
      end if;
   end Write_Base64;


   procedure Write_Hex (Output : in out Printer; Data : in Atom) is
      Available : Screen_Offset;
      I : Offset := Data'First;
      Chunk_Size : Count;
   begin
      if Output.Param.Width = 0 then
         Output.Stream.Write ((0 => Encodings.Hex_Atom_Begin));
         Output.Stream.Write (Encodings.Encode_Hex (Data,
                                                    Output.Param.Hex_Casing));
         Output.Stream.Write ((0 => Encodings.Hex_Atom_End));
      else
         Output.Stream.Write ((0 => Encodings.Hex_Atom_Begin));
         Output.Cursor := Output.Cursor + 1;

         loop
            Available := Output.Param.Width - Output.Cursor;
            Chunk_Size := Count (Available) / 2;

            if Available mod 2 = 1 then
               Output.Stream.Write ((0 => Encodings.Space));
               Output.Cursor := Output.Cursor + 1;
            end if;

            if I + Chunk_Size in Data'Range then
               Output.Stream.Write (Encodings.Encode_Hex
                                      (Data (I .. I + Chunk_Size - 1),
                                       Output.Param.Hex_Casing));
               Newline (Output);
               I := I + Chunk_Size;
            else
               Output.Stream.Write (Encodings.Encode_Hex
                                      (Data (I .. Data'Last),
                                       Output.Param.Hex_Casing));
               Output.Stream.Write ((0 => Encodings.Hex_Atom_End));
               Output.Cursor := Output.Cursor
                 + Screen_Offset (Data'Last - I + 1) * 2 + 1;
               exit;
            end if;
         end loop;
      end if;
   end Write_Hex;


   procedure Write_Quoted
     (Output : in out Printer;
      Data : in Atom;
      Single_Line : in Boolean)
   is
      procedure Escape
        (Value : in Octet;
         Result : out Atom;
         Pos : in out Offset);

      Size : Count;
      Last_Non_NL : Offset := Data'Last;

      procedure Escape
        (Value : in Octet;
         Result : out Atom;
         Pos : in out Offset) is
      begin
         Result (Pos) := Encodings.Escape;

         case Output.Param.Quoted_Escape is
            when Octal_Escape =>
               Result (Pos + 1) := Encodings.Digit_0 + (Value / 2**6);
               Result (Pos + 2) := Encodings.Digit_0 + (Value / 2**3) mod 2**3;
               Result (Pos + 3) := Encodings.Digit_0 + (Value mod 2**3);
            when Hex_Escape =>
               Result (Pos + 1) := Character'Pos ('x');
               Encodings.Encode_Hex
                 (Value,
                  Output.Param.Hex_Casing,
                  Result (Pos + 2),
                  Result (Pos + 3));
         end case;
         Pos := Pos + 4;
      end Escape;
   begin
      declare
         Discarded_Cursor : Screen_Offset := Output.Cursor;
      begin
         Quoted_Lengths
           (Data,
            Output.Param.Char_Encoding,
            Output.Param.Width,
            Output.Param.Newline,
            Single_Line,
            Size,
            Discarded_Cursor);
      end;

      while Last_Non_NL in Data'Range
        and then (Data (Last_Non_NL) = Encodings.CR
                  or Data (Last_Non_NL) = Encodings.LF)
      loop
         Last_Non_NL := Last_Non_NL - 1;
      end loop;

      declare
         Result : Atom (0 .. Size - 1);
         I : Offset := Data'First;
         O : Offset := Result'First + 1;
         C : Count;
      begin
         Result (0) := Encodings.Quoted_Atom_Begin;
         Output.Cursor := Output.Cursor + 1;

         while I in Data'Range loop
            case Data (I) is
               when 8 =>
                  Result (O) := Encodings.Escape;
                  Result (O + 1) := Character'Pos ('b');
                  O := O + 2;
                  Output.Cursor := Output.Cursor + 2;
               when 9 =>
                  Result (O) := Encodings.Escape;
                  Result (O + 1) := Character'Pos ('t');
                  O := O + 2;
                  Output.Cursor := Output.Cursor + 2;
               when 10 =>
                  if Single_Line
                    or else I > Last_Non_NL
                    or else not Is_Newline (Data, I, Output.Param.Newline)
                  then
                     Result (O) := Encodings.Escape;
                     Result (O + 1) := Character'Pos ('n');
                     O := O + 2;
                     Output.Cursor := Output.Cursor + 2;
                  else
                     Result (O) := Data (I);
                     O := O + 1;
                     Output.Cursor := 1;
                  end if;
               when 11 =>
                  Result (O) := Encodings.Escape;
                  Result (O + 1) := Character'Pos ('v');
                  O := O + 2;
                  Output.Cursor := Output.Cursor + 2;
               when 12 =>
                  Result (O) := Encodings.Escape;
                  Result (O + 1) := Character'Pos ('f');
                  O := O + 2;
                  Output.Cursor := Output.Cursor + 2;
               when 13 =>
                  if Single_Line
                    or else I > Last_Non_NL
                    or else not Is_Newline (Data, I, Output.Param.Newline)
                  then
                     Result (O) := Encodings.Escape;
                     Result (O + 1) := Character'Pos ('r');
                     O := O + 2;
                     Output.Cursor := Output.Cursor + 2;
                  else
                     Result (O) := Data (I);
                     O := O + 1;
                     Output.Cursor := 1;
                  end if;
               when Encodings.Quoted_Atom_End | Encodings.Escape =>
                  Result (O) := Encodings.Escape;
                  Result (O + 1) := Data (I);
                  O := O + 2;
                  Output.Cursor := Output.Cursor + 2;
               when 0 .. 7 | 14 .. 31 =>
                  Escape (Data (I), Result, O);
                  Output.Cursor := Output.Cursor + 4;
               when 16#80# .. 16#FF# =>
                  case Output.Param.Char_Encoding is
                     when ASCII =>
                        Escape (Data (I), Result, O);
                        Output.Cursor := Output.Cursor + 4;
                     when Latin =>
                        if Data (I) in 16#80# .. 16#9F# then
                           Escape (Data (I), Result, O);
                           Output.Cursor := Output.Cursor + 4;
                        else
                           Result (O) := Data (I);
                           O := O + 1;
                           Output.Cursor := Output.Cursor + 1;
                        end if;
                     when UTF_8 =>
                        C := UTF_Character_Size (Data, I);
                        if C = 0 then
                           Escape (Data (I), Result, O);
                           Output.Cursor := Output.Cursor + 4;
                        else
                           Result (O .. O + C - 1) := Data (I .. I + C - 1);
                           O := O + C;
                           I := I + C - 1;
                           Output.Cursor := Output.Cursor + 1;
                        end if;
                  end case;
               when others =>
                  Result (O) := Data (I);
                  O := O + 1;
                  Output.Cursor := Output.Cursor + 1;
            end case;

            if not Single_Line
              and then Output.Param.Width > 0
              and then Output.Cursor >= Output.Param.Width
            then
               Result (O) := Encodings.Escape;
               case Output.Param.Newline is
                  when CR =>
                     Result (O + 1) := Encodings.CR;
                     O := O + 2;
                  when LF =>
                     Result (O + 1) := Encodings.LF;
                     O := O + 2;
                  when CR_LF =>
                     Result (O + 1) := Encodings.CR;
                     Result (O + 2) := Encodings.LF;
                     O := O + 3;
                  when LF_CR =>
                     Result (O + 1) := Encodings.LF;
                     Result (O + 2) := Encodings.CR;
                     O := O + 3;
               end case;
               Output.Cursor := 1;
            end if;

            I := I + 1;
         end loop;

         pragma Assert (O = Result'Last);
         Result (O) := Encodings.Quoted_Atom_End;

         Output.Stream.Write (Result);
      end;
   end Write_Quoted;


   procedure Write_Verbatim (Output : in out Printer; Data : in Atom) is
      Length_Image : constant String := Count'Image (Data'Length);
      Prefix : Atom (0 .. Length_Image'Length - 1);
   begin
      for I in Length_Image'First + 1 .. Length_Image'Last loop
         Prefix (Count (I) - Count (Length_Image'First + 1)) :=
           Character'Pos (Length_Image (I));
      end loop;
      Prefix (Prefix'Last) := Encodings.Verbatim_Begin;

      Output.Stream.Write (Prefix);
      Output.Stream.Write (Data);
      Output.Cursor := Output.Cursor + Screen_Offset (Prefix'Length)
        + Screen_Offset (Data'Length);
   end Write_Verbatim;



   -----------------------
   -- Printer Interface --
   -----------------------

   overriding procedure Open_List (Output : in out Printer) is
   begin
      if not Output.First then
         if Output.Param.Newline_At (Output.Previous, Opening) then
            Newline (Output);
         elsif Output.Param.Space_At (Output.Previous, Opening) then
            Output.Stream.Write ((0 => Encodings.Space));
            Output.Cursor := Output.Cursor + 1;
         end if;
      else
         Output.First := False;
      end if;

      Output.Stream.Write ((0 => Encodings.List_Begin));
      Output.Cursor := Output.Cursor + 1;
      Output.Indent_Level := Output.Indent_Level + 1;
      Output.Previous := Opening;
      Output.Need_Blank := False;
   end Open_List;


   overriding procedure Append_Atom (Output : in out Printer;
                                     Data : in Atom)
   is
      Blank_Width : Screen_Offset;
      At_Origin : Boolean := False;
   begin
      if not Output.First then
         if Output.Param.Newline_At (Output.Previous, Atom_Data) then
            Newline (Output);
            Output.Need_Blank := False;
            At_Origin := True;
         elsif Output.Param.Space_At (Output.Previous, Atom_Data) then
            Output.Need_Blank := True;
         end if;
      else
         Output.First := False;
         Output.Need_Blank := False;
         At_Origin := True;
      end if;
      Output.Previous := Atom_Data;

      if Output.Need_Blank then
         Blank_Width := 1;
      else
         Blank_Width := 0;
      end if;

      --  Token encoding if requested and possible

      if (Output.Param.Token = Extended_Token
          and then Is_Extended_Token (Data))
        or else (Output.Param.Token = Standard_Token
                 and then Is_Standard_Token (Data))
      then
         declare
            Width : constant Screen_Offset
              := Single_Line_Quoted_Width (Data, Output.Param.Char_Encoding)
                 - 2;
         begin
            if not At_Origin
              and then not Fit_In_Line (Output, Blank_Width + Width)
            then
               Newline (Output);
            elsif Output.Need_Blank then
               Output.Stream.Write ((0 => Encodings.Space));
               Output.Cursor := Output.Cursor + 1;
            end if;
            Output.Stream.Write (Data);
            Output.Cursor := Output.Cursor + Width;
            Output.Need_Blank := True;
            return;
         end;
      end if;

      --  Single-line quoted string if requested and possible

      if Output.Param.Quoted = Single_Line then
         declare
            Width : constant Screen_Offset
              := Single_Line_Quoted_Width (Data, Output.Param.Char_Encoding);
         begin
            if Fit_In_Line (Output, Blank_Width + Width) then
               if Output.Need_Blank then
                  Output.Stream.Write ((0 => Encodings.Space));
               end if;
               Write_Quoted (Output, Data, True);
               Output.Cursor := Output.Cursor + Blank_Width + Width;
               Output.Need_Blank := False;
               return;
            end if;

            if Indent_Width (Output) + Width <= Output.Param.Width then
               Newline (Output);
               Write_Quoted (Output, Data, True);
               Output.Cursor := Output.Cursor + Width;
               Output.Need_Blank := False;
               return;
            end if;
         end;
      end if;

      --  Fall back on a universal token encoding

      declare
         Size : Count;
      begin
         case Output.Param.Fallback is
            when Base64 =>
               Size := (Data'Length + 2) / 3 * 4 + 2;
            when Hexadecimal =>
               Size := Data'Length * 2 + 2;
            when Verbatim =>
               declare
                  I : Count := 10;
               begin
                  Size := 2;
                  while Data'Length >= I loop
                     Size := Size + 1;
                     I := I * 10;
                  end loop;
               end;
         end case;

         if Output.Param.Quoted = When_Shorter
           and then Multi_Line_Quoted_Size (Output, Data) <= Size
         then
            if Output.Need_Blank then
               Output.Stream.Write ((0 => Encodings.Space));
               Output.Cursor := Output.Cursor + 1;
            end if;
            Write_Quoted (Output, Data, False);
            Output.Need_Blank := False;
            return;
         end if;

--       if Output.Param.Quoted = When_Shorter then
--          String'Write (Output.Stream,
--            "{" & Count'Image (Size) & "|"
--            & Count'Image (Multi_Line_Quoted_Size (Output, Data)) & "}");
--       end if;

         if not At_Origin
           and then
           not Fit_In_Line (Output, Blank_Width + Screen_Offset (Size))
         then
            Newline (Output);
         elsif Output.Need_Blank then
            Output.Stream.Write ((0 => Encodings.Space));
            Output.Cursor := Output.Cursor + 1;
         end if;

         case Output.Param.Fallback is
            when Base64 =>
               Write_Base64 (Output, Data);
            when Hexadecimal =>
               Write_Hex (Output, Data);
            when Verbatim =>
               Write_Verbatim (Output, Data);
         end case;
         Output.Need_Blank := False;
      end;
   end Append_Atom;


   overriding procedure Close_List (Output : in out Printer) is
   begin
      Output.Indent_Level := Output.Indent_Level - 1;

      if not Output.First then
         if Output.Param.Newline_At (Output.Previous, Closing) then
            Newline (Output);
         elsif Output.Param.Space_At (Output.Previous, Closing) then
            Output.Stream.Write ((0 => Encodings.Space));
            Output.Cursor := Output.Cursor + 1;
         end if;
      else
         Output.First := False;
      end if;

      Output.Stream.Write ((0 => Encodings.List_End));
      Output.Cursor := Output.Cursor + 1;
      Output.Previous := Closing;
      Output.Need_Blank := False;
   end Close_List;



   ---------------------------
   -- Configuration Methods --
   ---------------------------

   procedure Set_Parameters (Output : in out Printer; Param : in Parameters) is
   begin
      Output.Param := Param;
   end Set_Parameters;


   function Get_Parameters (Output : Printer) return Parameters is
   begin
      return Output.Param;
   end Get_Parameters;


   procedure Set_Width
     (Output : in out Printer;
      Width : in Screen_Offset) is
   begin
      Output.Param.Width := Width;
   end Set_Width;


   procedure Set_Newline_At
     (Output : in out Printer;
      Newline_At : in Entity_Separator) is
   begin
      Output.Param.Newline_At := Newline_At;
   end Set_Newline_At;


   procedure Set_Space_At
     (Output : in out Printer;
      Space_At : in Entity_Separator) is
   begin
      Output.Param.Space_At := Space_At;
   end Set_Space_At;


   procedure Set_Tab_Stop
     (Output : in out Printer;
      Tab_Stop : in Screen_Column) is
   begin
      Output.Param.Tab_Stop := Tab_Stop;
   end Set_Tab_Stop;


   procedure Set_Indentation
     (Output : in out Printer;
      Indentation : in Screen_Offset) is
   begin
      Output.Param.Indentation := Indentation;
   end Set_Indentation;


   procedure Set_Indent
     (Output : in out Printer;
      Indent : in Indent_Type) is
   begin
      Output.Param.Indent := Indent;
   end Set_Indent;


   procedure Set_Quoted
     (Output : in out Printer;
      Quoted : in Quoted_Option) is
   begin
      Output.Param.Quoted := Quoted;
   end Set_Quoted;


   procedure Set_Token
     (Output : in out Printer;
      Token : in Token_Option) is
   begin
      Output.Param.Token := Token;
   end Set_Token;


   procedure Set_Hex_Casing
     (Output : in out Printer;
      Hex_Casing : in Encodings.Hex_Casing) is
   begin
      Output.Param.Hex_Casing := Hex_Casing;
   end Set_Hex_Casing;


   procedure Set_Quoted_Escape
     (Output : in out Printer;
      Quoted_Escape : in Quoted_Escape_Type) is
   begin
      Output.Param.Quoted_Escape := Quoted_Escape;
   end Set_Quoted_Escape;


   procedure Set_Char_Encoding
     (Output : in out Printer;
      Char_Encoding : in Character_Encoding) is
   begin
      Output.Param.Char_Encoding := Char_Encoding;
   end Set_Char_Encoding;


   procedure Set_Fallback
     (Output : in out Printer;
      Fallback : in Atom_Encoding) is
   begin
      Output.Param.Fallback := Fallback;
   end Set_Fallback;


   procedure Set_Newline
     (Output : in out Printer;
      Newline : in Newline_Encoding) is
   begin
      Output.Param.Newline := Newline;
   end Set_Newline;

end Natools.S_Expressions.Printers.Pretty;

------------------------------------------------------------------------------
-- Copyright (c) 2013-2014, Natacha Porté                                   --
--                                                                          --
-- Permission to use, copy, modify, and distribute this software for any    --
-- purpose with or without fee is hereby granted, provided that the above   --
-- copyright notice and this permission notice appear in all copies.        --
--                                                                          --
-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES --
-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         --
-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  --
-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   --
-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    --
-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  --
-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           --
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Natools.S_Expressions.Printers.Pretty provides an implementation of the  --
-- S-expression Printer interface, using user-defines perferences to pretty --
-- print the S-expression into the output stream.                           --
------------------------------------------------------------------------------

with Ada.Streams;

with Natools.S_Expressions.Encodings;

package Natools.S_Expressions.Printers.Pretty is
   pragma Pure (Pretty);

   type Atom_Encoding is (Base64, Hexadecimal, Verbatim);
   type Character_Encoding is (ASCII, Latin, UTF_8);
   type Newline_Encoding is (CR, LF, CR_LF, LF_CR);
   type Entity is (Opening, Atom_Data, Closing);
   type Entity_Separator is array (Entity, Entity) of Boolean;
   type Indent_Type is (Spaces, Tabs, Tabs_And_Spaces);
   type Quoted_Escape_Type is (Hex_Escape, Octal_Escape);
   type Quoted_Option is (When_Shorter, Single_Line, No_Quoted);
   type Token_Option is (Extended_Token, Standard_Token, No_Token);
   type Screen_Offset is new Natural;

   subtype Screen_Column is Screen_Offset range 1 .. Screen_Offset'Last;

   type Parameters is record
      Width         : Screen_Offset;
      Newline_At    : Entity_Separator;
      Space_At      : Entity_Separator;
      Tab_Stop      : Screen_Column;
      Indentation   : Screen_Offset;
      Indent        : Indent_Type;
      Quoted        : Quoted_Option;
      Token         : Token_Option;
      Hex_Casing    : Encodings.Hex_Casing;
      Quoted_Escape : Quoted_Escape_Type;
      Char_Encoding : Character_Encoding;
      Fallback      : Atom_Encoding;
      Newline       : Newline_Encoding;
   end record;

   Canonical : constant Parameters;

   type Printer (Stream : access Ada.Streams.Root_Stream_Type'Class) is
     new Printers.Printer with private;

   overriding procedure Open_List (Output : in out Printer);
   overriding procedure Append_Atom
     (Output : in out Printer;
      Data : in Atom);
   overriding procedure Close_List (Output : in out Printer);

   procedure Set_Parameters (Output : in out Printer; Param : in Parameters);
   function Get_Parameters (Output : Printer) return Parameters;

   procedure Set_Width
     (Output : in out Printer;
      Width : in Screen_Offset);
   procedure Set_Newline_At
     (Output : in out Printer;
      Newline_At : in Entity_Separator);
   procedure Set_Space_At
     (Output : in out Printer;
      Space_At : in Entity_Separator);
   procedure Set_Tab_Stop
     (Output : in out Printer;
      Tab_Stop : in Screen_Column);
   procedure Set_Indentation
     (Output : in out Printer;
      Indentation : in Screen_Offset);
   procedure Set_Indent
     (Output : in out Printer;
      Indent : in Indent_Type);
   procedure Set_Quoted
     (Output : in out Printer;
      Quoted : in Quoted_Option);
   procedure Set_Token
     (Output : in out Printer;
      Token : in Token_Option);
   procedure Set_Hex_Casing
     (Output : in out Printer;
      Hex_Casing : in Encodings.Hex_Casing);
   procedure Set_Quoted_Escape
     (Output : in out Printer;
      Quoted_Escape : in Quoted_Escape_Type);
   procedure Set_Char_Encoding
     (Output : in out Printer;
      Char_Encoding : in Character_Encoding);
   procedure Set_Fallback
     (Output : in out Printer;
      Fallback : in Atom_Encoding);
   procedure Set_Newline
     (Output : in out Printer;
      Newline : in Newline_Encoding);

private

   type Printer (Stream : access Ada.Streams.Root_Stream_Type'Class) is
     new Printers.Printer with record
      Param        : Parameters;
      Cursor       : Screen_Column := 1;
      Previous     : Entity;
      First        : Boolean := True;
      Indent_Level : Screen_Offset := 0;
      Need_Blank   : Boolean := False;
   end record;

   Canonical : constant Parameters :=
     (Width         => 0,
      Newline_At    => (others => (others => False)),
      Space_At      => (others => (others => False)),
      Tab_Stop      => 8,  --  unused
      Indentation   => 0,
      Indent        => Spaces,  --  unused
      Quoted        => No_Quoted,
      Token         => No_Token,
      Hex_Casing    => Encodings.Upper,  --  unused
      Quoted_Escape => Octal_Escape,  --  unused
      Char_Encoding => ASCII,  --  unused
      Fallback      => Verbatim,
      Newline       => LF);  --  unused

end Natools.S_Expressions.Printers.Pretty;