Natools

natools-s_expressions-printers-pretty-config.adb at trunk
Login

File src/natools-s_expressions-printers-pretty-config.adb artifact b2995c3780 on branch trunk


------------------------------------------------------------------------------
-- 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.           --
------------------------------------------------------------------------------

with Natools.S_Expressions.Interpreter_Loop;
with Natools.S_Expressions.Printers.Pretty.Config.Commands;

package body Natools.S_Expressions.Printers.Pretty.Config is

   procedure Read_Screen_Offset
     (Expression : in Lockable.Descriptor'Class;
      Value : in out Screen_Offset;
      Has_Value : out Boolean);
      --  Decode a screen offset from a S-expression

   procedure Update_Casing
     (Casing : in out Encodings.Hex_Casing;
      Name : in Atom);

   function To_Atom (Value : in Screen_Offset) return Atom;
   function To_Atom (Before, After : in Entity) return Atom;

   function To_String (Value : in Entity) return String;


   procedure Main_Execute
     (Param : in out Parameters;
      Context : in Meaningless_Type;
      Name : in Atom);

   procedure Main_Execute
     (Param : in out Parameters;
      Context : in Meaningless_Type;
      Name : in Atom;
      Arguments : in out Lockable.Descriptor'Class);

   procedure Newline_Execute
     (Param : in out Parameters;
      Context : in Meaningless_Type;
      Name : in Atom);

   procedure Newline_Execute
     (Param : in out Parameters;
      Context : in Meaningless_Type;
      Name : in Atom;
      Arguments : in out Lockable.Descriptor'Class);

   procedure Newline_Interpreter
     (Expression : in out Lockable.Descriptor'Class;
      Param : in out Parameters);

   procedure Quoted_Execute
     (Param : in out Parameters;
      Context : in Meaningless_Type;
      Name : in Atom);

   procedure Quoted_Interpreter
     (Expression : in out Lockable.Descriptor'Class;
      Param : in out Parameters);

   procedure Separator_Execute
     (State : in out Entity_Separator;
      Value : in Boolean;
      Name : in Atom);

   procedure Separator_Execute
     (State : in out Entity_Separator;
      Value : in Boolean;
      Name : in Atom;
      Arguments : in out Lockable.Descriptor'Class);

   procedure Separator_Interpreter
     (Expression : in out Lockable.Descriptor'Class;
      State : in out Entity_Separator;
      Context : in Boolean);


   ------------------
   -- Interpreters --
   ------------------

   procedure Main_Execute
     (Param : in out Parameters;
      Context : in Meaningless_Type;
      Name : in Atom)
   is
      pragma Unreferenced (Context);
      Command : constant String := To_String (Name);
   begin
      case Commands.Main (Command) is
         when Commands.Set_Char_Encoding =>
            Param.Char_Encoding := Commands.To_Character_Encoding (Command);

         when Commands.Set_Fallback =>
            Param.Fallback := Commands.To_Atom_Encoding (Command);
            Update_Casing (Param.Hex_Casing, Name);

         when Commands.Set_Hex_Casing =>
            Param.Hex_Casing := Commands.To_Hex_Casing (Command);

         when Commands.Set_Indentation =>
            Param.Indentation := 0;

         when Commands.Set_Newline_Encoding =>
            Param.Newline := Commands.To_Newline_Encoding (Command);

         when Commands.Set_Quoted =>
            Param.Quoted := Commands.To_Quoted_Option (Command);

         when Commands.Set_Token =>
            Param.Token := Commands.To_Token_Option (Command);

         when Commands.Set_Width =>
            Param.Width := 0;

         when Commands.Set_Newline
           | Commands.Set_Quoted_String
           | Commands.Set_Space_At
           | Commands.Set_Tab_Stop
         =>
            --  Those commands are meaningless without argument
            null;
      end case;
   end Main_Execute;


   procedure Main_Execute
     (Param : in out Parameters;
      Context : in Meaningless_Type;
      Name : in Atom;
      Arguments : in out Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      Command : constant String := To_String (Name);
   begin
      case Commands.Main (Command) is
         when Commands.Set_Indentation =>
            declare
               Has_Value : Boolean;
               Event : Events.Event;
            begin
               Read_Screen_Offset (Arguments, Param.Indentation, Has_Value);

               if Has_Value and then Param.Indentation /= 0 then
                  Arguments.Next (Event);

                  if Event = Events.Add_Atom then
                     declare
                        Unit : constant String
                          := To_String (Arguments.Current_Atom);
                        Last : Natural := Unit'Last;
                     begin
                        if Last > 0 and then Unit (Last) = 's' then
                           Last := Last - 1;
                        end if;

                        if Unit (Unit'First .. Last) = "tab" then
                           Param.Indent := Tabs;
                        elsif Unit (Unit'First .. Last) = "space" then
                           Param.Indent := Spaces;
                        elsif Unit (Unit'First .. Last) = "tabbed-space" then
                           Param.Indent := Tabs_And_Spaces;
                        end if;
                     end;
                  end if;
               end if;
            end;

         when Commands.Set_Newline =>
            Newline_Interpreter (Arguments, Param);

         when Commands.Set_Quoted_String =>
            Quoted_Interpreter (Arguments, Param);

         when Commands.Set_Space_At =>
            Separator_Interpreter (Arguments, Param.Space_At, True);

         when Commands.Set_Tab_Stop =>
            declare
               Value : Screen_Offset := 0;
               Has_Value : Boolean;
            begin
               Read_Screen_Offset (Arguments, Value, Has_Value);

               if Has_Value and then Value /= 0 then
                  Param.Tab_Stop := Value;
               end if;
            end;

         when Commands.Set_Token =>
            begin
               if Arguments.Current_Event = Events.Add_Atom then
                  Param.Token := Commands.To_Token_Option
                    (To_String (Arguments.Current_Atom));
               end if;
            exception
               when Constraint_Error => null;
            end;

         when Commands.Set_Width =>
            declare
               Has_Value : Boolean;
            begin
               Read_Screen_Offset (Arguments, Param.Width, Has_Value);
            end;

         when Commands.Set_Char_Encoding
           | Commands.Set_Fallback
           | Commands.Set_Hex_Casing
           | Commands.Set_Newline_Encoding
           | Commands.Set_Quoted
         =>
            --  These commands don't do anything with arguments
            null;
      end case;
   end Main_Execute;


   procedure Newline_Execute
     (Param : in out Parameters;
      Context : in Meaningless_Type;
      Name : in Atom)
   is
      pragma Unreferenced (Context);
      Command : constant String := To_String (Name);
   begin
      case Commands.Newline (Command) is
         when Commands.Set_Newline_Command_Encoding =>
            Param.Newline := Commands.To_Newline_Encoding (Command);
         when Commands.Set_Newline_Separator =>
            Separator_Execute (Param.Newline_At, True, Name);
      end case;
   end Newline_Execute;


   procedure Newline_Execute
     (Param : in out Parameters;
      Context : in Meaningless_Type;
      Name : in Atom;
      Arguments : in out Lockable.Descriptor'Class)
   is
      pragma Unreferenced (Context);
      Command : constant String := To_String (Name);
   begin
      case Commands.Newline (Command) is
         when Commands.Set_Newline_Command_Encoding =>
            Param.Newline := Commands.To_Newline_Encoding (Command);
         when Commands.Set_Newline_Separator =>
            Separator_Execute (Param.Newline_At, True, Name, Arguments);
      end case;
   end Newline_Execute;


   procedure Quoted_Execute
     (Param : in out Parameters;
      Context : in Meaningless_Type;
      Name : in Atom)
   is
      pragma Unreferenced (Context);
      Command : constant String := To_String (Name);
   begin
      case Commands.Quoted_String (Command) is
         when Commands.Set_Quoted_Option =>
            Param.Quoted := Commands.To_Quoted_Option (Command);
         when Commands.Set_Quoted_Escape =>
            Param.Quoted_Escape := Commands.To_Quoted_Escape (Command);
            Update_Casing (Param.Hex_Casing, Name);
      end case;
   end Quoted_Execute;


   procedure Separator_Execute
     (State : in out Entity_Separator;
      Value : in Boolean;
      Name : in Atom) is
   begin
      case Commands.Separator (To_String (Name)) is
         when Commands.All_Separators =>
            State := (others => (others => Value));
         when Commands.No_Separators =>
            State := (others => (others => not Value));

         when Commands.Invert_Separators =>
            null;  --  Error, actually

         when Commands.Open_Open =>
            State (Opening, Opening) := Value;
         when Commands.Open_Atom =>
            State (Opening, Atom_Data) := Value;
         when Commands.Open_Close =>
            State (Opening, Closing) := Value;

         when Commands.Atom_Open =>
            State (Atom_Data, Opening) := Value;
         when Commands.Atom_Atom =>
            State (Atom_Data, Atom_Data) := Value;
         when Commands.Atom_Close =>
            State (Atom_Data, Closing) := Value;

         when Commands.Close_Open =>
            State (Closing, Opening) := Value;
         when Commands.Close_Atom =>
            State (Closing, Atom_Data) := Value;
         when Commands.Close_Close =>
            State (Closing, Closing) := Value;
      end case;
   end Separator_Execute;


   procedure Separator_Execute
     (State : in out Entity_Separator;
      Value : in Boolean;
      Name : in Atom;
      Arguments : in out Lockable.Descriptor'Class) is
   begin
      case Commands.Separator (To_String (Name)) is
         when Commands.Invert_Separators =>
            Separator_Interpreter (Arguments, State, not Value);

         when Commands.All_Separators
           | Commands.No_Separators
           | Commands.Open_Open
           | Commands.Open_Atom
           | Commands.Open_Close
           | Commands.Atom_Open
           | Commands.Atom_Atom
           | Commands.Atom_Close
           | Commands.Close_Open
           | Commands.Close_Atom
           | Commands.Close_Close
         =>
            Separator_Execute (State, Value, Name);
      end case;
   end Separator_Execute;



   procedure Main_Interpreter is new Interpreter_Loop
     (Parameters, Meaningless_Type, Main_Execute, Main_Execute);

   procedure Newline_Interpreter is new Interpreter_Loop
     (Parameters, Meaningless_Type, Newline_Execute, Newline_Execute);

   procedure Quoted_Interpreter is new Interpreter_Loop
     (Parameters, Meaningless_Type,
      Dispatch_Without_Argument => Quoted_Execute);

   procedure Interpreter is new Interpreter_Loop
     (Entity_Separator, Boolean, Separator_Execute, Separator_Execute);



   procedure Newline_Interpreter
     (Expression : in out Lockable.Descriptor'Class;
      Param : in out Parameters) is
   begin
      Newline_Interpreter (Expression, Param, Meaningless_Value);
   end Newline_Interpreter;

   procedure Quoted_Interpreter
     (Expression : in out Lockable.Descriptor'Class;
      Param : in out Parameters) is
   begin
      Quoted_Interpreter (Expression, Param, Meaningless_Value);
   end Quoted_Interpreter;

   procedure Separator_Interpreter
     (Expression : in out Lockable.Descriptor'Class;
      State : in out Entity_Separator;
      Context : in Boolean)
     renames Interpreter;



   ------------------------------
   -- Local Helper Subprograms --
   ------------------------------

   procedure Read_Screen_Offset
     (Expression : in Lockable.Descriptor'Class;
      Value : in out Screen_Offset;
      Has_Value : out Boolean)
   is
      Result : Screen_Offset := 0;
   begin
      Has_Value := False;

      if Expression.Current_Event /= Events.Add_Atom then
         return;
      end if;

      declare
         Data : constant Atom := Expression.Current_Atom;
      begin
         if Data'Length = 0 then
            return;
         end if;

         for I in Data'Range loop
            if Data (I) in Encodings.Digit_0 .. Encodings.Digit_9 then
               Result := Result * 10
                 + Screen_Offset (Data (I) - Encodings.Digit_0);
            else
               return;
            end if;
         end loop;

         Has_Value := True;
         Value := Result;
      end;
   end Read_Screen_Offset;


   function To_Atom (Value : in Screen_Offset) return Atom is
      Length : Count;
   begin
      Compute_Length : declare
         Left : Screen_Offset := Value;
      begin
         Length := 1;
         while Left >= 10 loop
            Length := Length + 1;
            Left := Left / 10;
         end loop;
      end Compute_Length;

      return Result : Atom (0 .. Length - 1) do
         declare
            I : Offset := Result'Last;
            Left : Screen_Offset := Value;
         begin
            loop
               Result (I) := Encodings.Digit_0 + Octet (Left mod 10);
               I := I - 1;
               Left := Left / 10;
               exit when Left = 0;
            end loop;
            pragma Assert (I + 1 = Result'First);
         end;
      end return;
   end To_Atom;


   function To_Atom (Before, After : in Entity) return Atom is
   begin
      return To_Atom (To_String (Before) & "-" & To_String (After));
   end To_Atom;


   function To_String (Value : in Entity) return String is
   begin
      case Value is
         when Opening => return "open";
         when Atom_Data => return "atom";
         when Closing => return "close";
      end case;
   end To_String;


   procedure Update_Casing
     (Casing : in out Encodings.Hex_Casing;
      Name : in Atom) is
   begin
      if Name'Length > 5 then
         declare
            Prefix : constant String
              := To_String (Name (Name'First .. Name'First + 4));
         begin
            if Prefix = "upper" then
               Casing := Encodings.Upper;
            elsif Prefix = "lower" then
               Casing := Encodings.Lower;
            end if;
         end;
      end if;
   end Update_Casing;



   ---------------------------------
   -- Public High Level Interface --
   ---------------------------------

   procedure Print
     (Output : in out Printers.Printer'Class;
      Param : in Parameters) is
   begin
      --  Newline_At and Newline

      Output.Open_List;
      Output.Append_Atom (To_Atom ("newline"));
      case Param.Newline is
         when CR =>    Output.Append_Atom (To_Atom ("cr"));
         when LF =>    Output.Append_Atom (To_Atom ("lf"));
         when CR_LF => Output.Append_Atom (To_Atom ("cr-lf"));
         when LF_CR => Output.Append_Atom (To_Atom ("lf-cr"));
      end case;

      if Param.Newline_At = Entity_Separator'(others => (others => True)) then
         Output.Append_Atom (To_Atom ("all"));
      else
         Output.Append_Atom (To_Atom ("none"));
         for Before in Entity loop
            for After in Entity loop
               if Param.Newline_At (Before, After) then
                  Output.Append_Atom (To_Atom (Before, After));
               end if;
            end loop;
         end loop;
      end if;
      Output.Close_List;

      --  Space_At

      Output.Open_List;
      Output.Append_Atom (To_Atom ("space"));
      if Param.Space_At = Entity_Separator'(others => (others => True)) then
         Output.Append_Atom (To_Atom ("all"));
      else
         Output.Append_Atom (To_Atom ("none"));
         for Before in Entity loop
            for After in Entity loop
               if Param.Space_At (Before, After) then
                  Output.Append_Atom (To_Atom (Before, After));
               end if;
            end loop;
         end loop;
      end if;
      Output.Close_List;

      --  Tab_Stop

      Output.Open_List;
      Output.Append_Atom (To_Atom ("tab-stop"));
      Output.Append_Atom (To_Atom (Param.Tab_Stop));
      Output.Close_List;

      --  Width

      if Param.Width > 0 then
         Output.Open_List;
         Output.Append_Atom (To_Atom ("width"));
         Output.Append_Atom (To_Atom (Param.Width));
         Output.Close_List;
      else
         Output.Append_Atom (To_Atom ("no-width"));
      end if;

      --  Indentation and Indent

      if Param.Indentation = 0 then
         Output.Append_Atom (To_Atom ("no-indentation"));
      else
         Output.Open_List;
         Output.Append_Atom (To_Atom ("indentation"));
         Output.Append_Atom (To_Atom (Param.Indentation));
         if Param.Indentation > 1 then
            case Param.Indent is
               when Spaces =>
                  Output.Append_Atom (To_Atom ("spaces"));
               when Tabs =>
                  Output.Append_Atom (To_Atom ("tabs"));
               when Tabs_And_Spaces =>
                  Output.Append_Atom (To_Atom ("tabbed-spaces"));
            end case;
         else
            case Param.Indent is
               when Spaces =>
                  Output.Append_Atom (To_Atom ("space"));
               when Tabs =>
                  Output.Append_Atom (To_Atom ("tab"));
               when Tabs_And_Spaces =>
                  Output.Append_Atom (To_Atom ("tabbed-space"));
            end case;
         end if;
         Output.Close_List;
      end if;

      --  Quoted

      case Param.Quoted is
         when No_Quoted    =>
            Output.Append_Atom (To_Atom ("no-quoted-string"));
         when Single_Line  =>
            Output.Append_Atom (To_Atom ("single-line-quoted-string"));
         when When_Shorter =>
            Output.Append_Atom (To_Atom ("quoted-string-when-shorter"));
      end case;

      --  Quoted_Escape

      Output.Open_List;
      Output.Append_Atom (To_Atom ("escape"));
      case Param.Quoted_Escape is
         when Octal_Escape => Output.Append_Atom (To_Atom ("octal"));
         when Hex_Escape   => Output.Append_Atom (To_Atom ("hexadecimal"));
      end case;
      Output.Close_List;

      --  Token

      Output.Open_List;
      Output.Append_Atom (To_Atom ("token"));
      case Param.Token is
         when No_Token       => Output.Append_Atom (To_Atom ("never"));
         when Extended_Token => Output.Append_Atom (To_Atom ("extended"));
         when Standard_Token => Output.Append_Atom (To_Atom ("standard"));
      end case;
      Output.Close_List;

      --  Char_Encoding

      case Param.Char_Encoding is
         when UTF_8 => Output.Append_Atom (To_Atom ("utf-8"));
         when ASCII => Output.Append_Atom (To_Atom ("ascii"));
         when Latin => Output.Append_Atom (To_Atom ("latin-1"));
      end case;

      --  Hex_Casing

      case Param.Hex_Casing is
         when Encodings.Upper => Output.Append_Atom (To_Atom ("upper-case"));
         when Encodings.Lower => Output.Append_Atom (To_Atom ("lower-case"));
      end case;

      --  Fallback

      case Param.Fallback is
         when Base64      => Output.Append_Atom (To_Atom ("base-64"));
         when Hexadecimal => Output.Append_Atom (To_Atom ("hexadecimal"));
         when Verbatim    => Output.Append_Atom (To_Atom ("verbatim"));
      end case;
   end Print;


   procedure Update
     (Param : in out Parameters;
      Expression : in out Lockable.Descriptor'Class) is
   begin
      Main_Interpreter (Expression, Param, Meaningless_Value);
   end Update;

end Natools.S_Expressions.Printers.Pretty.Config;