------------------------------------------------------------------------------
-- 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.Config is
procedure Read_Screen_Offset
(Expression : in out Lockable.Descriptor'Class;
Value : 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 (Before, After : in Entity) return Atom;
function To_String (Value : in Entity) return String;
------------------------------
-- Local Helper Subprograms --
------------------------------
procedure Read_Screen_Offset
(Expression : in out Lockable.Descriptor'Class;
Value : 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 (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 Update
(Param : in out Parameters;
Expression : in out Lockable.Descriptor'Class)
is
Interpreter : Interpreters.Interpreter := Config_Interpreter;
begin
Update (Interpreter, Param, Expression);
end Update;
procedure Update
(Interpreter : in out Interpreters.Interpreter;
Param : in out Parameters;
Expression : in out Lockable.Descriptor'Class) is
begin
Interpreter.Execute (Expression, Param, True);
end Update;
------------------------------
-- Interpreter Constructors --
------------------------------
function Config_Interpreter return Interpreters.Interpreter is
Result : Interpreters.Interpreter;
begin
Result.Add_Command (To_Atom ("escape"),
Set_Quoted_String'(others => <>));
Result.Add_Command (To_Atom ("indent"), Set_Indentation'(null record));
Result.Add_Command (To_Atom ("indentation"),
Set_Indentation'(null record));
Result.Add_Command (To_Atom ("no-indent"),
Set_Indentation'(null record));
Result.Add_Command (To_Atom ("no-indentation"),
Set_Indentation'(null record));
Result.Add_Command (To_Atom ("newline"), Set_Newline'(others => <>));
Result.Add_Command (To_Atom ("quoted"),
Set_Quoted_String'(others => <>));
Result.Add_Command (To_Atom ("space"), Set_Space_At'(others => <>));
Result.Add_Command (To_Atom ("tab-stop"), Set_Tab_Stop'(null record));
Result.Add_Command (To_Atom ("width"), Set_Width'(null record));
Result.Add_Command (To_Atom ("no-width"), Set_Width'(null record));
Result.Add_Command (To_Atom ("extended-token"),
Set_Token'(Value => Extended_Token));
Result.Add_Command (To_Atom ("no-token"),
Set_Token'(Value => No_Token));
Result.Add_Command (To_Atom ("standard-token"),
Set_Token'(Value => Standard_Token));
Result.Add_Command (To_Atom ("token"),
Set_Token'(Value => Standard_Token));
Result.Add_Command (To_Atom ("no-quoted"),
Set_Quoted'(Value => No_Quoted));
Result.Add_Command (To_Atom ("no-quoted-string"),
Set_Quoted'(Value => No_Quoted));
Result.Add_Command (To_Atom ("quoted-when-shorter"),
Set_Quoted'(Value => When_Shorter));
Result.Add_Command (To_Atom ("quoted-string-when-shorter"),
Set_Quoted'(Value => When_Shorter));
Result.Add_Command (To_Atom ("single-line-quoted"),
Set_Quoted'(Value => Single_Line));
Result.Add_Command (To_Atom ("single-line-quoted-string"),
Set_Quoted'(Value => Single_Line));
Result.Add_Command (To_Atom ("base64"),
Set_Fallback'(Value => Base64));
Result.Add_Command (To_Atom ("base-64"),
Set_Fallback'(Value => Base64));
Result.Add_Command (To_Atom ("lower-hex"),
Set_Fallback'(Value => Hexadecimal));
Result.Add_Command (To_Atom ("lower-hexa"),
Set_Fallback'(Value => Hexadecimal));
Result.Add_Command (To_Atom ("hex"),
Set_Fallback'(Value => Hexadecimal));
Result.Add_Command (To_Atom ("hexa"),
Set_Fallback'(Value => Hexadecimal));
Result.Add_Command (To_Atom ("hexadecimal"),
Set_Fallback'(Value => Hexadecimal));
Result.Add_Command (To_Atom ("upper-hex"),
Set_Fallback'(Value => Hexadecimal));
Result.Add_Command (To_Atom ("upper-hexa"),
Set_Fallback'(Value => Hexadecimal));
Result.Add_Command (To_Atom ("verbatim"),
Set_Fallback'(Value => Verbatim));
Add_Char_Encoding_Commands (Result);
Add_Hex_Casing_Commands (Result);
Add_Newline_Encoding_Commands (Result);
return Result;
end Config_Interpreter;
procedure Add_Char_Encoding_Commands
(Interpreter : in out Interpreters.Interpreter) is
begin
Interpreter.Add_Command (To_Atom ("utf-8"),
Set_Char_Encoding'(Value => UTF_8));
Interpreter.Add_Command (To_Atom ("UTF-8"),
Set_Char_Encoding'(Value => UTF_8));
Interpreter.Add_Command (To_Atom ("utf8"),
Set_Char_Encoding'(Value => UTF_8));
Interpreter.Add_Command (To_Atom ("UTF8"),
Set_Char_Encoding'(Value => UTF_8));
Interpreter.Add_Command (To_Atom ("ascii"),
Set_Char_Encoding'(Value => ASCII));
Interpreter.Add_Command (To_Atom ("ASCII"),
Set_Char_Encoding'(Value => ASCII));
Interpreter.Add_Command (To_Atom ("latin-1"),
Set_Char_Encoding'(Value => Latin));
Interpreter.Add_Command (To_Atom ("latin"),
Set_Char_Encoding'(Value => Latin));
Interpreter.Add_Command (To_Atom ("iso-8859-1"),
Set_Char_Encoding'(Value => Latin));
Interpreter.Add_Command (To_Atom ("ISO-8859-1"),
Set_Char_Encoding'(Value => Latin));
end Add_Char_Encoding_Commands;
procedure Add_Hex_Casing_Commands
(Interpreter : in out Interpreters.Interpreter) is
begin
Interpreter.Add_Command (To_Atom ("upper"),
Set_Hex_Casing'(Value => Encodings.Upper));
Interpreter.Add_Command (To_Atom ("upper-case"),
Set_Hex_Casing'(Value => Encodings.Upper));
Interpreter.Add_Command (To_Atom ("lower"),
Set_Hex_Casing'(Value => Encodings.Lower));
Interpreter.Add_Command (To_Atom ("lower-case"),
Set_Hex_Casing'(Value => Encodings.Lower));
end Add_Hex_Casing_Commands;
procedure Add_Quoted_Commands
(Interpreter : in out Interpreters.Interpreter) is
begin
Interpreter.Add_Command (To_Atom ("never"),
Set_Quoted'(Value => No_Quoted));
Interpreter.Add_Command (To_Atom ("single-line"),
Set_Quoted'(Value => Single_Line));
Interpreter.Add_Command (To_Atom ("when-shorter"),
Set_Quoted'(Value => When_Shorter));
end Add_Quoted_Commands;
procedure Add_Quoted_Escape_Commands
(Interpreter : in out Interpreters.Interpreter) is
begin
Interpreter.Add_Command (To_Atom ("octal"),
Set_Quoted_Escape'(Value => Octal_Escape));
Interpreter.Add_Command (To_Atom ("hex"),
Set_Quoted_Escape'(Value => Hex_Escape));
Interpreter.Add_Command (To_Atom ("hexa"),
Set_Quoted_Escape'(Value => Hex_Escape));
Interpreter.Add_Command (To_Atom ("hexadecimal"),
Set_Quoted_Escape'(Value => Hex_Escape));
Interpreter.Add_Command (To_Atom ("lower-hex"),
Set_Quoted_Escape'(Value => Hex_Escape));
Interpreter.Add_Command (To_Atom ("lower-hexa"),
Set_Quoted_Escape'(Value => Hex_Escape));
Interpreter.Add_Command (To_Atom ("upper-hex"),
Set_Quoted_Escape'(Value => Hex_Escape));
Interpreter.Add_Command (To_Atom ("upper-hexa"),
Set_Quoted_Escape'(Value => Hex_Escape));
Add_Hex_Casing_Commands (Interpreter);
end Add_Quoted_Escape_Commands;
procedure Add_Newline_Encoding_Commands
(Interpreter : in out Interpreters.Interpreter) is
begin
Interpreter.Add_Command (To_Atom ("cr"),
Set_Newline_Encoding'(Value => CR));
Interpreter.Add_Command (To_Atom ("CR"),
Set_Newline_Encoding'(Value => CR));
Interpreter.Add_Command (To_Atom ("lf"),
Set_Newline_Encoding'(Value => LF));
Interpreter.Add_Command (To_Atom ("LF"),
Set_Newline_Encoding'(Value => LF));
Interpreter.Add_Command (To_Atom ("CRLF"),
Set_Newline_Encoding'(Value => CR_LF));
Interpreter.Add_Command (To_Atom ("CR-LF"),
Set_Newline_Encoding'(Value => CR_LF));
Interpreter.Add_Command (To_Atom ("crlf"),
Set_Newline_Encoding'(Value => CR_LF));
Interpreter.Add_Command (To_Atom ("cr-lf"),
Set_Newline_Encoding'(Value => CR_LF));
Interpreter.Add_Command (To_Atom ("lf-cr"),
Set_Newline_Encoding'(Value => LF_CR));
Interpreter.Add_Command (To_Atom ("lfcr"),
Set_Newline_Encoding'(Value => LF_CR));
Interpreter.Add_Command (To_Atom ("LF-CR"),
Set_Newline_Encoding'(Value => LF_CR));
Interpreter.Add_Command (To_Atom ("LFCR"),
Set_Newline_Encoding'(Value => LF_CR));
end Add_Newline_Encoding_Commands;
procedure Add_Separator_Commands
(Interpreter : in out Interpreters.Interpreter;
Value : in Boolean;
Newline : in Boolean) is
begin
for Before in Entity loop
for After in Entity loop
Interpreter.Add_Command
(To_Atom (Before, After),
Set_Separator'(Before, After, Value, Newline));
end loop;
end loop;
Interpreter.Add_Command
(To_Atom ("all"),
Set_All_Separators'(Value, Newline));
Interpreter.Add_Command
(To_Atom ("none"),
Set_All_Separators'(not Value, Newline));
Interpreter.Add_Command
(To_Atom ("not"),
Set_All_Separators'(not Value, Newline));
end Add_Separator_Commands;
-------------------------
-- Invididual Commands --
-------------------------
procedure Execute
(Self : in out Set_Width;
State : in out Parameters;
Context : in Boolean;
Name : in Atom)
is
pragma Unreferenced (Self, Context, Name);
begin
State.Width := 0;
end Execute;
procedure Execute
(Self : in out Set_Width;
State : in out Parameters;
Context : in Boolean;
Cmd : in out Lockable.Descriptor'Class)
is
pragma Unreferenced (Self, Context);
Has_Value : Boolean;
begin
Cmd.Next;
Read_Screen_Offset (Cmd, State.Width, Has_Value);
end Execute;
procedure Execute
(Self : in out Set_Tab_Stop;
State : in out Parameters;
Context : in Boolean;
Cmd : in out Lockable.Descriptor'Class)
is
pragma Unreferenced (Self, Context);
Value : Screen_Offset;
Has_Value : Boolean;
begin
Cmd.Next;
Read_Screen_Offset (Cmd, Value, Has_Value);
if Has_Value and then Value /= 0 then
State.Tab_Stop := Value;
end if;
end Execute;
procedure Execute
(Self : in out Set_Indentation;
State : in out Parameters;
Context : in Boolean;
Name : in Atom)
is
pragma Unreferenced (Self, Context, Name);
begin
State.Indentation := 0;
end Execute;
procedure Execute
(Self : in out Set_Indentation;
State : in out Parameters;
Context : in Boolean;
Cmd : in out Lockable.Descriptor'Class)
is
pragma Unreferenced (Self, Context);
Has_Value : Boolean;
Event : Events.Event;
begin
Cmd.Next (Event);
Read_Screen_Offset (Cmd, State.Indentation, Has_Value);
if Has_Value and State.Indentation /= 0 then
Cmd.Next (Event);
if Event = Events.Add_Atom then
declare
Keyword : constant String := To_String (Cmd.Current_Atom);
begin
if Keyword = "tab" or Keyword = "tabs" then
State.Indent := Tabs;
elsif Keyword = "space" or Keyword = "spaces" then
State.Indent := Spaces;
elsif Keyword = "tabbed-space" or Keyword = "tabbed-spaces" then
State.Indent := Tabs_And_Spaces;
end if;
end;
end if;
end if;
end Execute;
procedure Execute
(Self : in out Set_Newline;
State : in out Parameters;
Context : in Boolean;
Cmd : in out Lockable.Descriptor'Class) is
begin
if Self.Subinterpreter.Is_Empty then
Add_Separator_Commands (Self.Subinterpreter, True, True);
Add_Newline_Encoding_Commands (Self.Subinterpreter);
end if;
Cmd.Next;
Self.Subinterpreter.Execute (Cmd, State, Context);
end Execute;
procedure Execute
(Self : in out Set_Space_At;
State : in out Parameters;
Context : in Boolean;
Cmd : in out Lockable.Descriptor'Class) is
begin
if Self.Subinterpreter.Is_Empty then
Add_Separator_Commands (Self.Subinterpreter, True, False);
end if;
Cmd.Next;
Self.Subinterpreter.Execute (Cmd, State, Context);
end Execute;
procedure Execute
(Self : in out Set_Char_Encoding;
State : in out Parameters;
Context : in Boolean;
Name : in Atom)
is
pragma Unreferenced (Context, Name);
begin
State.Char_Encoding := Self.Value;
end Execute;
procedure Execute
(Self : in out Set_Newline_Encoding;
State : in out Parameters;
Context : in Boolean;
Name : in Atom)
is
pragma Unreferenced (Context, Name);
begin
State.Newline := Self.Value;
end Execute;
procedure Execute
(Self : in out Set_Separator;
State : in out Parameters;
Context : in Boolean;
Name : in Atom)
is
pragma Unreferenced (Context, Name);
begin
if Self.Newline then
State.Newline_At (Self.Before, Self.After) := Self.Value;
else
State.Space_At (Self.Before, Self.After) := Self.Value;
end if;
end Execute;
procedure Execute
(Self : in out Set_All_Separators;
State : in out Parameters;
Context : in Boolean;
Name : in Atom)
is
pragma Unreferenced (Context, Name);
begin
if Self.Newline then
State.Newline_At := (others => (others => Self.Value));
else
State.Space_At := (others => (others => Self.Value));
end if;
end Execute;
procedure Execute
(Self : in out Set_All_Separators;
State : in out Parameters;
Context : in Boolean;
Cmd : in out Lockable.Descriptor'Class)
is
Subinterpreter : Interpreters.Interpreter;
begin
Add_Separator_Commands (Subinterpreter, Self.Value, Self.Newline);
Subinterpreter.Execute (Cmd, State, Context);
end Execute;
procedure Execute
(Self : in out Set_Hex_Casing;
State : in out Parameters;
Context : in Boolean;
Name : in Atom)
is
pragma Unreferenced (Context, Name);
begin
State.Hex_Casing := Self.Value;
end Execute;
procedure Execute
(Self : in out Set_Fallback;
State : in out Parameters;
Context : in Boolean;
Name : in Atom)
is
pragma Unreferenced (Context);
begin
State.Fallback := Self.Value;
Update_Casing (State.Hex_Casing, Name);
end Execute;
procedure Execute
(Self : in out Set_Token;
State : in out Parameters;
Context : in Boolean;
Name : in Atom)
is
pragma Unreferenced (Context, Name);
begin
State.Token := Self.Value;
end Execute;
procedure Execute
(Self : in out Set_Token;
State : in out Parameters;
Context : in Boolean;
Cmd : in out Lockable.Descriptor'Class)
is
pragma Unreferenced (Self, Context);
Event : Events.Event;
begin
Cmd.Next (Event);
if Event /= Events.Add_Atom then
return;
end if;
declare
Token : constant String := To_String (Cmd.Current_Atom);
begin
if Token = "standard" then
State.Token := Standard_Token;
elsif Token = "extended" then
State.Token := Extended_Token;
elsif Token = "never" or Token = "none" or Token = "no" then
State.Token := No_Token;
end if;
end;
end Execute;
procedure Execute
(Self : in out Set_Quoted_Escape;
State : in out Parameters;
Context : in Boolean;
Name : in Atom)
is
pragma Unreferenced (Context);
begin
State.Quoted_Escape := Self.Value;
Update_Casing (State.Hex_Casing, Name);
end Execute;
procedure Execute
(Self : in out Set_Quoted;
State : in out Parameters;
Context : in Boolean;
Name : in Atom)
is
pragma Unreferenced (Context, Name);
begin
State.Quoted := Self.Value;
end Execute;
procedure Execute
(Self : in out Set_Quoted_String;
State : in out Parameters;
Context : in Boolean;
Cmd : in out Lockable.Descriptor'Class) is
begin
if Self.Subinterpreter.Is_Empty then
Add_Quoted_Commands (Self.Subinterpreter);
Add_Quoted_Escape_Commands (Self.Subinterpreter);
end if;
Cmd.Next;
Self.Subinterpreter.Execute (Cmd, State, Context);
end Execute;
end Natools.S_Expressions.Printers.Pretty.Config;