Natools

natools-s_expressions-printers-pretty.adb at [6eaac2a01c]
Login

File src/natools-s_expressions-printers-pretty.adb artifact 33ea8fdc6a part of check-in 6eaac2a01c


------------------------------------------------------------------------------
-- 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 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 - 1 + 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;
      Writer : Printer'Class renames Printer'Class (Output);
   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;
      Writer.Write_Raw (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;
               Writer.Write_Raw
                 ((1 .. Count (Output.Cursor) - 1 => Encodings.Space));
            when Tabs =>
               Output.Cursor := Output.Param.Indentation * Output.Indent_Level;
               Writer.Write_Raw ((1 .. Count (Output.Cursor) => Encodings.HT));
               Output.Cursor := Output.Cursor * Output.Param.Tab_Stop + 1;
            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
                  Writer.Write_Raw ((1 .. Tab_Count => Encodings.HT));
                  Writer.Write_Raw ((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;
      Input_Delta : Count;
      Output_Delta : Count;
      Width_Adjust : Offset;
      New_Cursor : Screen_Column;
   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
         Input_Delta := 1;
         Width_Adjust := 0;
         case Data (I) is
            when 8 | 9 | 11 | 12
              | Encodings.Quoted_Atom_End | Encodings.Escape =>
               Output_Delta := 2;
            when 10 | 13 =>
               if Single_Line
                 or else I > Last_Non_NL
                 or else not Is_Newline (Data, I, Newline)
               then
                  Output_Delta := 2;
               else
                  Width_Adjust := -Offset (Cursor);
                  case Newline is
                     when LF | CR =>
                        Output_Delta := 1;
                     when CR_LF | LF_CR =>
                        Output_Delta := 2;
                        Input_Delta := 2;
                        Width_Adjust := Width_Adjust - 1;
                  end case;
               end if;
            when 0 .. 7 | 14 .. 31 =>
               Output_Delta := 4;
            when 16#80# .. 16#FF# =>
               case Encoding is
                  when ASCII =>
                     Output_Delta := 4;
                  when Latin =>
                     if Data (I) in 16#80# .. 16#9F# then
                        Output_Delta := 4;
                     else
                        Output_Delta := 1;
                     end if;
                  when UTF_8 =>
                     C := UTF_Character_Size (Data, I);
                     if C = 0 then
                        Output_Delta := 4;
                     else
                        Output_Delta := C;
                        Input_Delta := C;
                        Width_Adjust := 1 - C;
                     end if;
               end case;
            when others =>
               Output_Delta := 1;
         end case;

         New_Cursor := Screen_Column
           (Offset (Cursor) + Output_Delta + Width_Adjust);

         if not Single_Line
           and then Width > 0
           and then Cursor > 1
           and then (New_Cursor > Width + 1
             or else (New_Cursor = Width + 1
               and then I + 1 in Data'Range
               and then not Is_Newline (Data, I + 1, Newline)))
         then
            case Newline is
               when CR | LF =>
                  Size := Size + 2;
               when CR_LF | LF_CR =>
                  Size := Size + 3;
            end case;
            Cursor := 1;
         else
            I := I + Input_Delta;
            Size := Size + Output_Delta;
            Cursor := New_Cursor;
         end if;
      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;
      Writer : Printer'Class renames Printer'Class (Output);
   begin
      if Output.Param.Width = 0 then
         Writer.Write_Raw ((0 => Encodings.Base64_Atom_Begin));
         Writer.Write_Raw (Encodings.Encode_Base64 (Data));
         Writer.Write_Raw ((0 => Encodings.Base64_Atom_End));
      else
         Writer.Write_Raw ((0 => Encodings.Base64_Atom_Begin));
         Output.Cursor := Output.Cursor + 1;

         loop
            Available := Output.Param.Width + 1 - Output.Cursor;
            Chunk_Size := Count'Max (1, Count (Available) / 4) * 3;

            if Available mod 4 /= 0 and then I in Data'Range then
               Writer.Write_Raw
                 (((1 .. Count (Available mod 4) => Encodings.Space)));
               Output.Cursor := Output.Cursor + (Available mod 4);
            end if;

            if I + Chunk_Size - 1 in Data'Range then
               Writer.Write_Raw
                 (Encodings.Encode_Base64 (Data (I .. I + Chunk_Size - 1)));
               Newline (Output);
               I := I + Chunk_Size;
            else
               Writer.Write_Raw
                 (Encodings.Encode_Base64 (Data (I .. Data'Last)));
               Writer.Write_Raw ((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;
      Writer : Printer'Class renames Printer'Class (Output);
   begin
      if Output.Param.Width = 0 then
         Writer.Write_Raw ((0 => Encodings.Hex_Atom_Begin));
         Writer.Write_Raw
           (Encodings.Encode_Hex (Data, Output.Param.Hex_Casing));
         Writer.Write_Raw ((0 => Encodings.Hex_Atom_End));
      else
         Writer.Write_Raw ((0 => Encodings.Hex_Atom_Begin));
         Output.Cursor := Output.Cursor + 1;

         loop
            Available := Output.Param.Width + 1 - Output.Cursor;
            Chunk_Size := Count'Max (1, Count (Available) / 2);

            if Available mod 2 = 1 and then I in Data'Range then
               Writer.Write_Raw ((0 => Encodings.Space));
               Output.Cursor := Output.Cursor + 1;
            end if;

            if I + Chunk_Size - 1 in Data'Range then
               Writer.Write_Raw
                 (Encodings.Encode_Hex
                    (Data (I .. I + Chunk_Size - 1),
                     Output.Param.Hex_Casing));
               Newline (Output);
               I := I + Chunk_Size;
            else
               Writer.Write_Raw
                 (Encodings.Encode_Hex
                    (Data (I .. Data'Last),
                     Output.Param.Hex_Casing));
               Writer.Write_Raw ((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 : in out Atom;
         Pos : in Offset);

      Size : Count;
      Last_Non_NL : Offset := Data'Last;
      Expected_Cursor : Screen_Offset := Output.Cursor;

      procedure Escape
        (Value : in Octet;
         Result : in out Atom;
         Pos : in 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;
      end Escape;
   begin
      Quoted_Lengths
        (Data,
         Output.Param.Char_Encoding,
         Output.Param.Width,
         Output.Param.Newline,
         Single_Line,
         Size,
         Expected_Cursor);

      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;
         Input_Delta : Count;
         Output_Delta : Count;
         Width_Adjust : Offset;
         New_Cursor : Screen_Column;
      begin
         Result (0) := Encodings.Quoted_Atom_Begin;
         Output.Cursor := Output.Cursor + 1;

         while I in Data'Range loop
            Output_Delta := 1;
            Width_Adjust := 0;
            Input_Delta := 1;

            case Data (I) is
               when 8 =>
                  Result (O) := Encodings.Escape;
                  Result (O + 1) := Character'Pos ('b');
                  Output_Delta := 2;
               when 9 =>
                  Result (O) := Encodings.Escape;
                  Result (O + 1) := Character'Pos ('t');
                  Output_Delta := 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');
                     Output_Delta := 2;
                  else
                     Result (O) := Data (I);
                     Width_Adjust := -Offset (Output.Cursor);
                     if Output.Param.Newline = CR_LF
                       or Output.Param.Newline = LF_CR
                     then
                        Input_Delta := 2;
                        Result (O + 1) := Data (I + 1);
                        Output_Delta := 2;
                        Width_Adjust := Width_Adjust - 1;
                     end if;
                  end if;
               when 11 =>
                  Result (O) := Encodings.Escape;
                  Result (O + 1) := Character'Pos ('v');
                  Output_Delta := 2;
               when 12 =>
                  Result (O) := Encodings.Escape;
                  Result (O + 1) := Character'Pos ('f');
                  Output_Delta := 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');
                     Output_Delta := 2;
                  else
                     Result (O) := Data (I);
                     Width_Adjust := -Offset (Output.Cursor);
                     if Output.Param.Newline = CR_LF
                       or Output.Param.Newline = LF_CR
                     then
                        Input_Delta := 2;
                        Result (O + 1) := Data (I + 1);
                        Output_Delta := 2;
                        Width_Adjust := Width_Adjust - 1;
                     end if;
                  end if;
               when Encodings.Quoted_Atom_End | Encodings.Escape =>
                  Result (O) := Encodings.Escape;
                  Result (O + 1) := Data (I);
                  Output_Delta := 2;
               when 0 .. 7 | 14 .. 31 =>
                  Escape (Data (I), Result, O);
                  Output_Delta := 4;
               when 16#80# .. 16#FF# =>
                  case Output.Param.Char_Encoding is
                     when ASCII =>
                        Escape (Data (I), Result, O);
                        Output_Delta := 4;
                     when Latin =>
                        if Data (I) in 16#80# .. 16#9F# then
                           Escape (Data (I), Result, O);
                           Output_Delta := 4;
                        else
                           Result (O) := Data (I);
                        end if;
                     when UTF_8 =>
                        C := UTF_Character_Size (Data, I);
                        if C = 0 then
                           Escape (Data (I), Result, O);
                           Output_Delta := 4;
                        else
                           Result (O .. O + C - 1) := Data (I .. I + C - 1);
                           Input_Delta := C;
                           Output_Delta := C;
                           Width_Adjust := 1 - C;
                        end if;
                  end case;
               when others =>
                  Result (O) := Data (I);
            end case;

            New_Cursor := Screen_Column
              (Offset (Output.Cursor) + Output_Delta + Width_Adjust);

            if not Single_Line
              and then Output.Param.Width > 0
              and then Output.Cursor > 1
              and then (New_Cursor > Output.Param.Width + 1
                or else (New_Cursor = Output.Param.Width + 1
                  and then I + 1 in Data'Range
                  and then not Is_Newline (Data, I + 1, Output.Param.Newline)))
            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;
            else
               I := I + Input_Delta;
               O := O + Output_Delta;
               Output.Cursor := New_Cursor;
            end if;
         end loop;

         pragma Assert (O = Result'Last);
         Result (O) := Encodings.Quoted_Atom_End;
         Output.Cursor := Output.Cursor + 1;

         Write_Raw (Printer'Class (Output), Result);
      end;

      pragma Assert (Output.Cursor = Expected_Cursor);
   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;

      Write_Raw (Printer'Class (Output), Prefix);
      Write_Raw (Printer'Class (Output), 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 Output.Param.Width > 0
        and then Output.Cursor > Output.Param.Width
        and then Output.Cursor > Indent_Width (Output) + 1
      then
         Newline (Output);
         Output.First := True;  --  inhibit extra space or newline
      end if;

      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
            Write_Raw (Printer'Class (Output), (0 => Encodings.Space));
            Output.Cursor := Output.Cursor + 1;
         end if;
      else
         Output.First := False;
      end if;

      Write_Raw (Printer'Class (Output), (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
               Write_Raw (Printer'Class (Output), (0 => Encodings.Space));
               Output.Cursor := Output.Cursor + 1;
            end if;
            Write_Raw (Printer'Class (Output), 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
                  Write_Raw (Printer'Class (Output), (0 => Encodings.Space));
                  Output.Cursor := Output.Cursor + 1;
               end if;
               Write_Quoted (Output, Data, True);
               Output.Need_Blank := False;
               return;
            end if;

            if Indent_Width (Output) + Width <= Output.Param.Width then
               Newline (Output);
               Write_Quoted (Output, Data, True);
               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;
                  Size := Size + Data'Length;
               end;
         end case;

         if Output.Param.Quoted = When_Shorter
           and then Multi_Line_Quoted_Size (Output, Data) <= Size
         then
            if Output.Need_Blank then
               Write_Raw (Printer'Class (Output), (0 => Encodings.Space));
               Output.Cursor := Output.Cursor + 1;
            end if;
            Write_Quoted (Output, Data, False);
            Output.Need_Blank := False;
            return;
         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
            Write_Raw (Printer'Class (Output), (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 Output.Param.Width > 0
        and then Output.Cursor > Output.Param.Width
        and then Output.Cursor > Indent_Width (Output) + 1
      then
         Newline (Output);
         Output.First := True;  --  inhibit extra space or newline
      end if;

      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
            Write_Raw (Printer'Class (Output), (0 => Encodings.Space));
            Output.Cursor := Output.Cursor + 1;
         end if;
      else
         Output.First := False;
      end if;

      Write_Raw (Printer'Class (Output), (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;


   overriding procedure Write_Raw
     (Output : in out Stream_Printer;
      Data : in Ada.Streams.Stream_Element_Array) is
   begin
      Output.Stream.Write (Data);
   end Write_Raw;

end Natools.S_Expressions.Printers.Pretty;