Natools

File tests/natools-s_expressions-parsers-tests.adb artifact 36b7ad4f5a part of check-in 50d86c2bfe

------------------------------------------------------------------------------
-- 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.Printers;
with Natools.S_Expressions.Test_Tools;

package body Natools.S_Expressions.Parsers.Tests is

   procedure Check_Parsing
     (Report : in out NT.Reporter'Class;
      Name : in String;
      Parser : in Parsers.Parser;
      Input, Output : in Test_Tools.Memory_Stream);
      --  Report failure or success depending on Output seeing a mismatch
      --  or having pending data. Dump stream status if needed.

   generic
      Name : String;
      Source, Expected : Atom;
   procedure Blackbox_Test (Report : in out NT.Reporter'Class);
      --  Perform a simple blackbox test, feeding Source to a new parser
      --  plugged on a canonical printer and comparing with Expected.



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

   procedure Check_Parsing
     (Report : in out NT.Reporter'Class;
      Name : in String;
      Parser : in Parsers.Parser;
      Input, Output : in Test_Tools.Memory_Stream) is
   begin
      if Parser.Current_Event = Events.Error
        or else Output.Has_Mismatch
        or else Output.Unread_Expected /= Null_Atom
      then
         Report.Item (Name, NT.Fail);

         if Parser.Current_Event = Events.Error then
            Report.Info ("Parser in error state");
         end if;

         if Output.Has_Mismatch then
            Report.Info ("Mismatch at position"
              & Count'Image (Output.Mismatch_Index));
         end if;

         if Output.Unread_Expected /= Null_Atom then
            Report.Info ("Left to expect: """
              & To_String (Output.Unread_Expected) & '"');
         end if;

         Report.Info ("Remaining unread data: """
           & To_String (Input.Unread_Data) & '"');
         Report.Info ("Written data: """
           & To_String (Output.Get_Data) & '"');
      else
         Report.Item (Name, NT.Success);
      end if;
   end Check_Parsing;


   procedure Blackbox_Test (Report : in out NT.Reporter'Class) is
   begin
      declare
         Input, Output : aliased Test_Tools.Memory_Stream;
         Printer : Printers.Canonical (Output'Access);
         Parser : aliased Parsers.Parser;
         Sub : Subparser (Parser'Access, Input'Access);
      begin
         Output.Set_Expected (Expected);
         Input.Set_Data (Source);
         Parser.Next_Event (Input'Access);

         Printers.Transfer (Sub, Printer);

         Check_Parsing (Report, Name, Parser, Input, Output);
      end;
   exception
      when Error : others => Report.Report_Exception (Name, Error);
   end Blackbox_Test;



   -------------------------
   -- Complete Test Suite --
   -------------------------

   procedure All_Tests (Report : in out NT.Reporter'Class) is
   begin
      Canonical_Encoding (Report);
      Atom_Encodings (Report);
   end All_Tests;



   -----------------------
   -- Inidividual Tests --
   -----------------------

   procedure Atom_Encodings (Report : in out NT.Reporter'Class) is
      procedure Test is new Blackbox_Test
        (Name => "Basic atom encodings",
         Source => To_Atom ("17:Verbatim encoding"
           & """Quoted\040string"""
           & "#48657861646563696d616c2064756d70#"
           & "token "
           & "|QmFzZS02NCBlbmNvZGluZw==|"),
         Expected => To_Atom ("17:Verbatim encoding"
           & "13:Quoted string"
           & "16:Hexadecimal dump"
           & "5:token"
           & "16:Base-64 encoding"));
   begin
      Test (Report);
   end Atom_Encodings;


   procedure Canonical_Encoding (Report : in out NT.Reporter'Class) is
      Sample_Image : constant String
        := "3:The(5:quick((5:brown3:fox)5:jumps))9:over3:the()4:lazy0:3:dog";

      procedure Test is new Blackbox_Test
        (Name => "Canonical encoding",
         Source => To_Atom (Sample_Image),
         Expected => To_Atom (Sample_Image));
   begin
      Test (Report);
   end Canonical_Encoding;

end Natools.S_Expressions.Parsers.Tests;