ADDED tests/natools-s_expressions-printers-pretty-config-tests.adb Index: tests/natools-s_expressions-printers-pretty-config-tests.adb ================================================================== --- tests/natools-s_expressions-printers-pretty-config-tests.adb +++ tests/natools-s_expressions-printers-pretty-config-tests.adb @@ -0,0 +1,288 @@ +------------------------------------------------------------------------------ +-- 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.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 + Read_Test (Report); + end All_Tests; + + + + ---------------------- + -- Individual Tests -- + ---------------------- + + 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 : aliased Parsers.Parser; + Subparser : Parsers.Subparser (Parser'Access, 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, Subparser, Events.Open_List, 1); + Update (Param, Subparser); + Check_Param (Test, Param, Expected, "In first expression:"); + + Input.Write (To_Atom + ("(indentation 3 spaces)width(token extended)" + & "(newline (not close-close))")); + Expected.Indentation := 3; + Expected.Indent := Spaces; + Expected.Width := 0; + Expected.Token := Extended_Token; + Expected.Newline_At (Closing, Closing) := False; + Test_Tools.Next_And_Check (Test, Subparser, Events.Open_List, 1); + Update (Param, Subparser); + 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, Subparser, Events.Open_List, 1); + Update (Param, Subparser); + Check_Param (Test, Param, Expected, "In third expression:"); + + Input.Write (To_Atom + ("no-indentation(token never)")); + Expected.Indentation := 0; + Expected.Token := No_Token; + Test_Tools.Next_And_Check (Test, Subparser, Events.Add_Atom, 0); + Update (Param, Subparser); + Check_Param (Test, Param, Expected, "In fourth expression:"); + + Input.Write (To_Atom + ("lower-case(token standard)")); + Expected.Token := Standard_Token; + Expected.Hex_Casing := Encodings.Lower; + Test_Tools.Next_And_Check (Test, Subparser, Events.Add_Atom, 0); + Update (Param, Subparser); + Check_Param (Test, Param, Expected, "In fifth expression:"); + end; + exception + when Error : others => Test.Report_Exception (Error); + end Read_Test; + +end Natools.S_Expressions.Printers.Pretty.Config.Tests; ADDED tests/natools-s_expressions-printers-pretty-config-tests.ads Index: tests/natools-s_expressions-printers-pretty-config-tests.ads ================================================================== --- tests/natools-s_expressions-printers-pretty-config-tests.ads +++ tests/natools-s_expressions-printers-pretty-config-tests.ads @@ -0,0 +1,34 @@ +------------------------------------------------------------------------------ +-- 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. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.S_Expressions.Printers.Pretty.Cofnig.Tests provides a test suite -- +-- S-expression serialization and deserialization of pretty printer -- +-- parameters. -- +------------------------------------------------------------------------------ + +with Natools.Tests; + +package Natools.S_Expressions.Printers.Pretty.Config.Tests is + pragma Preelaborate (Tests); + + package NT renames Natools.Tests; + + procedure All_Tests (Report : in out NT.Reporter'Class); + + procedure Read_Test (Report : in out NT.Reporter'Class); + +end Natools.S_Expressions.Printers.Pretty.Config.Tests;