------------------------------------------------------------------------------
-- Copyright (c) 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.Encodings;
with Natools.S_Expressions.Parsers;
with Natools.S_Expressions.Printers.Pretty.Config.Commands.T;
with Natools.S_Expressions.Test_Tools;
package body Natools.S_Expressions.Printers.Pretty.Config.Tests is
procedure Check_Param
(Test : in out NT.Test;
Result : in Parameters;
Expected : in Parameters;
Context : in String := "");
------------------------------
-- Local Helper Subprograms --
------------------------------
procedure Check_Param
(Test : in out NT.Test;
Result : in Parameters;
Expected : in Parameters;
Context : in String := "")
is
use type Encodings.Hex_Casing;
function Image (E : Entity) return String;
function Image (Left, Right : Entity; Active : Boolean) return String;
function Image (Sep : Entity_Separator) return String;
function Image (I : Indent_Type) return String;
function Image (E : Entity) return String is
begin
case E is
when Opening => return "O";
when Atom_Data => return "A";
when Closing => return "C";
end case;
end Image;
function Image (Left, Right : Entity; Active : Boolean) return String is
begin
if Active then
return ' ' & Image (Left) & Image (Right);
else
return "";
end if;
end Image;
function Image (Sep : Entity_Separator) return String is
Result : String
:= Image (Opening, Opening, Sep (Opening, Opening))
& Image (Opening, Atom_Data, Sep (Opening, Atom_Data))
& Image (Opening, Closing, Sep (Opening, Closing))
& Image (Atom_Data, Opening, Sep (Atom_Data, Opening))
& Image (Atom_Data, Atom_Data, Sep (Atom_Data, Atom_Data))
& Image (Atom_Data, Closing, Sep (Atom_Data, Closing))
& Image (Closing, Opening, Sep (Closing, Opening))
& Image (Closing, Atom_Data, Sep (Closing, Atom_Data))
& Image (Closing, Closing, Sep (Closing, Closing))
& ')';
begin
if Result'Length = 1 then
return "()";
else
Result (Result'First) := '(';
return Result;
end if;
end Image;
function Image (I : Indent_Type) return String is
begin
case I is
when Spaces => return "spaces";
when Tabs => return "tabs";
when Tabs_And_Spaces => return "columns (with tabs)";
end case;
end Image;
begin
if Result = Expected then
return;
end if;
Test.Fail (Context);
if Result.Width /= Expected.Width then
Test.Info ("Found width"
& Screen_Offset'Image (Result.Width)
& ", expected"
& Screen_Offset'Image (Expected.Width));
end if;
if Result.Newline_At /= Expected.Newline_At then
Test.Info ("Found newline at "
& Image (Result.Newline_At)
& ", expected "
& Image (Expected.Newline_At));
end if;
if Result.Space_At /= Expected.Space_At then
Test.Info ("Found space at "
& Image (Result.Space_At)
& ", expected "
& Image (Expected.Space_At));
end if;
if Result.Tab_Stop /= Expected.Tab_Stop then
Test.Info ("Found tab stop"
& Screen_Offset'Image (Result.Tab_Stop)
& ", expected"
& Screen_Offset'Image (Expected.Tab_Stop));
end if;
if Result.Indentation /= Expected.Indentation
or Result.Indent /= Expected.Indent
then
Test.Info ("Found indentation"
& Screen_Offset'Image (Result.Indentation)
& ' ' & Image (Result.Indent)
& ", expected"
& Screen_Offset'Image (Expected.Indentation)
& ' ' & Image (Expected.Indent));
end if;
if Result.Quoted /= Expected.Quoted then
Test.Info ("Found quoted option "
& Quoted_Option'Image (Result.Quoted)
& ", expected "
& Quoted_Option'Image (Expected.Quoted));
end if;
if Result.Token /= Expected.Token then
Test.Info ("Found token option "
& Token_Option'Image (Result.Token)
& ", expected "
& Token_Option'Image (Expected.Token));
end if;
if Result.Hex_Casing /= Expected.Hex_Casing then
Test.Info ("Found hex casing "
& Encodings.Hex_Casing'Image (Result.Hex_Casing)
& ", expected "
& Encodings.Hex_Casing'Image (Expected.Hex_Casing));
end if;
if Result.Quoted_Escape /= Expected.Quoted_Escape then
Test.Info ("Found quoted escape "
& Quoted_Escape_Type'Image (Result.Quoted_Escape)
& ", expected "
& Quoted_Escape_Type'Image (Expected.Quoted_Escape));
end if;
if Result.Char_Encoding /= Expected.Char_Encoding then
Test.Info ("Found character encoding "
& Character_Encoding'Image (Result.Char_Encoding)
& ", expected "
& Character_Encoding'Image (Expected.Char_Encoding));
end if;
if Result.Newline /= Expected.Newline then
Test.Info ("Found newline encoding "
& Newline_Encoding'Image (Result.Newline)
& ", expected "
& Newline_Encoding'Image (Expected.Newline));
end if;
if Result.Fallback /= Result.Fallback then
Test.Info ("Found fallback atom encoding "
& Atom_Encoding'Image (Result.Fallback)
& ", expected "
& Atom_Encoding'Image (Expected.Fallback));
end if;
end Check_Param;
-------------------------
-- Complete Test Suite --
-------------------------
procedure All_Tests (Report : in out NT.Reporter'Class) is
begin
Hash_Function_Test (Report);
Read_Test (Report);
Write_Test (Report);
end All_Tests;
----------------------
-- Individual Tests --
----------------------
procedure Hash_Function_Test (Report : in out NT.Reporter'Class) is
Test : NT.Test := Report.Item ("Interpreter hash functions");
begin
if not Commands.T then
Test.Fail;
end if;
exception
when Error : others => Test.Report_Exception (Error);
end Hash_Function_Test;
procedure Read_Test (Report : in out NT.Reporter'Class) is
Test : NT.Test := Report.Item ("Read from S-expression");
begin
declare
Param : Parameters := Canonical;
Expected : Parameters;
Input : aliased Test_Tools.Memory_Stream;
Parser : Parsers.Stream_Parser (Input'Access);
begin
Input.Write (To_Atom
("(width 80)"
& "(newline cr-lf atom-atom all)"
& "utf-8"
& "(space none open-open open-atom open-close atom-open atom-atom"
& " atom-close close-open close-atom close-close)"
& "token"
& "(tab-stop 4)"
& "single-line-quoted-string"
& "(indentation 1 tab)"
& "lower-hex"
& "(escape hexadecimal)"));
Expected
:= (Width => 80,
Newline_At => (others => (others => True)),
Space_At => (others => (others => True)),
Tab_Stop => 4,
Indentation => 1,
Indent => Tabs,
Quoted => Single_Line,
Token => Standard_Token,
Hex_Casing => Encodings.Lower,
Quoted_Escape => Hex_Escape,
Char_Encoding => UTF_8,
Fallback => Hexadecimal,
Newline => CR_LF);
Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
Update (Param, Parser);
Check_Param (Test, Param, Expected, "In first expression:");
Input.Write (To_Atom
("(indentation 3 spaces)width(token extended)"
& "LF(quoted never)"
& "(newline (not close-close))"));
Expected.Indentation := 3;
Expected.Indent := Spaces;
Expected.Width := 0;
Expected.Token := Extended_Token;
Expected.Newline_At (Closing, Closing) := False;
Expected.Newline := LF;
Expected.Quoted := No_Quoted;
Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
Update (Param, Parser);
Check_Param (Test, Param, Expected, "In second expression:");
Input.Write (To_Atom
("(indentation 4 tabbed-spaces)upper-hex(width (10))(token)"));
Expected.Indentation := 4;
Expected.Indent := Tabs_And_Spaces;
Expected.Hex_Casing := Encodings.Upper;
Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
Update (Param, Parser);
Check_Param (Test, Param, Expected, "In third expression:");
Input.Write (To_Atom
("no-indentation(token never)(newline)(width 72)"));
Expected.Indentation := 0;
Expected.Token := No_Token;
Expected.Width := 72;
Test_Tools.Next_And_Check (Test, Parser, Events.Add_Atom, 0);
Update (Param, Parser);
Check_Param (Test, Param, Expected, "In fourth expression:");
Input.Write (To_Atom
("lower-case(token standard)(width 0:)"));
Expected.Token := Standard_Token;
Expected.Hex_Casing := Encodings.Lower;
Test_Tools.Next_And_Check (Test, Parser, Events.Add_Atom, 0);
Update (Param, Parser);
Check_Param (Test, Param, Expected, "In fifth expression:");
Input.Write (To_Atom
("(token unrecognized-junk)(width 0xBAD)"));
Test_Tools.Next_And_Check (Test, Parser, Events.Open_List, 1);
Update (Param, Parser);
Check_Param (Test, Param, Expected, "In sixth expression:");
end;
exception
when Error : others => Test.Report_Exception (Error);
end Read_Test;
procedure Write_Test (Report : in out NT.Reporter'Class) is
Test : NT.Test := Report.Item ("Write parameters into S-expression");
procedure Testcase
(Title : in String;
Param : in Parameters;
Expr : in String);
procedure Testcase
(Title : in String;
Param : in Parameters;
Expr : in String)
is
Buffer : aliased Test_Tools.Memory_Stream;
Output : Printers.Canonical (Buffer'Access);
Parser : Parsers.Stream_Parser (Buffer'Access);
Reread : Parameters := Pretty.Canonical;
begin
Buffer.Set_Expected (To_Atom (Expr));
Print (Output, Param);
Parser.Next;
Update (Reread, Parser);
Check_Param (Test, Reread, Param, Title);
Buffer.Check_Stream (Test);
end Testcase;
begin
Testcase ("First case:",
(Width => 80,
Newline_At => (others => (others => True)),
Space_At => (others => (others => True)),
Tab_Stop => 4,
Indentation => 1,
Indent => Tabs,
Quoted => Single_Line,
Token => Standard_Token,
Hex_Casing => Encodings.Lower,
Quoted_Escape => Hex_Escape,
Char_Encoding => UTF_8,
Fallback => Hexadecimal,
Newline => CR_LF),
"(7:newline5:cr-lf3:all)(5:space3:all)(8:tab-stop1:4)(5:width2:80)"
& "(11:indentation1:13:tab)25:single-line-quoted-string"
& "(6:escape11:hexadecimal)(5:token8:standard)5:utf-8"
& "10:lower-case11:hexadecimal");
Testcase ("Second case:",
(Width => 0,
Newline_At => (others => (Opening => True, others => False)),
Space_At => (others => (Atom_Data => True, others => False)),
Tab_Stop => 4,
Indentation => 1,
Indent => Spaces,
Quoted => No_Quoted,
Token => No_Token,
Hex_Casing => Encodings.Upper,
Quoted_Escape => Octal_Escape,
Char_Encoding => ASCII,
Fallback => Verbatim,
Newline => LF),
"(7:newline2:lf4:none9:open-open9:atom-open10:close-open)"
& "(5:space4:none9:open-atom9:atom-atom10:close-atom)"
& "(8:tab-stop1:4)"
& "8:no-width(11:indentation1:15:space)16:no-quoted-string"
& "(6:escape5:octal)(5:token5:never)5:ascii10:upper-case"
& "8:verbatim");
Testcase ("Third case:",
(Width => 0,
Newline_At => (others => (others => False)),
Space_At => (others => (others => False)),
Tab_Stop => 8,
Indentation => 1,
Indent => Tabs_And_Spaces,
Quoted => When_Shorter,
Token => Extended_Token,
Hex_Casing => Encodings.Lower,
Quoted_Escape => Octal_Escape,
Char_Encoding => Latin,
Fallback => Base64,
Newline => CR),
"(7:newline2:cr4:none)(5:space4:none)(8:tab-stop1:8)8:no-width"
& "(11:indentation1:112:tabbed-space)26:quoted-string-when-shorter"
& "(6:escape5:octal)(5:token8:extended)7:latin-1"
& "10:lower-case7:base-64");
Testcase ("Fourth case:",
(Width => 0,
Newline_At => (others => (others => True)),
Space_At => (others => (others => True)),
Tab_Stop => 8,
Indentation => 3,
Indent => Spaces,
Quoted => No_Quoted,
Token => No_Token,
Hex_Casing => Encodings.Lower,
Quoted_Escape => Octal_Escape,
Char_Encoding => ASCII,
Fallback => Base64,
Newline => LF_CR),
"(7:newline5:lf-cr3:all)(5:space3:all)(8:tab-stop1:8)8:no-width"
& "(11:indentation1:36:spaces)16:no-quoted-string"
& "(6:escape5:octal)(5:token5:never)5:ascii"
& "10:lower-case7:base-64");
Testcase ("Fifth case:",
(Width => 0,
Newline_At => (others => (others => True)),
Space_At => (others => (others => True)),
Tab_Stop => 8,
Indentation => 2,
Indent => Tabs,
Quoted => No_Quoted,
Token => No_Token,
Hex_Casing => Encodings.Lower,
Quoted_Escape => Octal_Escape,
Char_Encoding => ASCII,
Fallback => Base64,
Newline => LF),
"(7:newline2:lf3:all)(5:space3:all)(8:tab-stop1:8)8:no-width"
& "(11:indentation1:24:tabs)16:no-quoted-string"
& "(6:escape5:octal)(5:token5:never)5:ascii"
& "10:lower-case7:base-64");
Testcase ("Sixth case:",
(Width => 0,
Newline_At => (others => (others => True)),
Space_At => (others => (others => True)),
Tab_Stop => 8,
Indentation => 4,
Indent => Tabs_And_Spaces,
Quoted => No_Quoted,
Token => No_Token,
Hex_Casing => Encodings.Lower,
Quoted_Escape => Octal_Escape,
Char_Encoding => ASCII,
Fallback => Base64,
Newline => LF),
"(7:newline2:lf3:all)(5:space3:all)(8:tab-stop1:8)8:no-width"
& "(11:indentation1:413:tabbed-spaces)16:no-quoted-string"
& "(6:escape5:octal)(5:token5:never)5:ascii"
& "10:lower-case7:base-64");
Testcase ("Seventh case:",
(Width => 0,
Newline_At => (others => (others => True)),
Space_At => (others => (others => True)),
Tab_Stop => 8,
Indentation => 0,
Indent => Spaces,
Quoted => No_Quoted,
Token => No_Token,
Hex_Casing => Encodings.Lower,
Quoted_Escape => Octal_Escape,
Char_Encoding => ASCII,
Fallback => Base64,
Newline => LF),
"(7:newline2:lf3:all)(5:space3:all)(8:tab-stop1:8)8:no-width"
& "14:no-indentation16:no-quoted-string"
& "(6:escape5:octal)(5:token5:never)5:ascii"
& "10:lower-case7:base-64");
exception
when Error : others => Test.Report_Exception (Error);
end Write_Test;
end Natools.S_Expressions.Printers.Pretty.Config.Tests;