Natools

File src/natools-s_expressions-printers.adb artifact b0eaf58582 part of check-in 5e694df685

------------------------------------------------------------------------------
-- Copyright (c) 2013-2015, 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.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Encodings;

package body Natools.S_Expressions.Printers is

   overriding procedure Open_List (Output : in out Canonical) is
   begin
      Output.Stream.Write ((0 => Encodings.List_Begin));
   end Open_List;


   overriding procedure Append_Atom (Output : in out Canonical;
                                     Data : in Atom)
   is
      Length_Image : constant String := Count'Image (Data'Length);
      Length_Data  : Atom (0 .. Length_Image'Length);
   begin
      Length_Data (0 .. Length_Image'Length - 1) := To_Atom (Length_Image);
      Length_Data (Length_Data'Last) := Encodings.Verbatim_Begin;

      Output.Stream.Write (Length_Data (1 .. Length_Data'Last));
      Output.Stream.Write (Data);
   end Append_Atom;


   overriding procedure Close_List (Output : in out Canonical) is
   begin
      Output.Stream.Write ((0 => Encodings.List_End));
   end Close_List;


   procedure Append_String (Output : in out Printer'Class; Data : in String) is
   begin
      Append_Atom (Output, To_Atom (Data));
   end Append_String;


   procedure Transfer
     (Source : in out Descriptor'Class;
      Target : in out Printer'Class;
      Check_Level : in Boolean := False)
   is
      procedure Print_Atom (Data : in Atom);

      procedure Print_Atom (Data : in Atom) is
      begin
         Target.Append_Atom (Data);
      end Print_Atom;

      Event : Events.Event := Source.Current_Event;
      Starting_Level : Natural := Source.Current_Level;
   begin
      if Events."=" (Event, Events.Open_List) then
         Starting_Level := Starting_Level - 1;
      end if;

      loop
         case Event is
            when Events.Error | Events.End_Of_Input =>
               exit;
            when Events.Open_List =>
               Target.Open_List;
            when Events.Close_List =>
               exit when Check_Level
                 and then Source.Current_Level < Starting_Level;
               Target.Close_List;
            when Events.Add_Atom =>
               Source.Query_Atom (Print_Atom'Access);
         end case;

         Source.Next (Event);
      end loop;
   end Transfer;

end Natools.S_Expressions.Printers;