Natools

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

   ------------------------
   -- Helper Subprograms --
   ------------------------

   function To_Result (Succeeded : Boolean) return Result is
   begin
      if Succeeded then
         return Success;
      else
         return Fail;

   begin
      Item (Report, Test_Name, Code);
      Info (Report,
            "Exception " & Ada.Exceptions.Exception_Name (Ex) & " raised:");
      Info (Report, Ada.Exceptions.Exception_Message (Ex));
   end Report_Exception;



   -----------------
   -- Test Object --
   -----------------

   function Item
     (Report : access Reporter'Class;
      Name : String;
      Default_Outcome : Result := Success)
     return Test is
   begin
      return Test'(Ada.Finalization.Limited_Controlled with
         Report => Report,
         Name => Ada.Strings.Unbounded.To_Unbounded_String (Name),
         Info => Info_Lists.Empty_List,
         Outcome => Default_Outcome,
         Finalized => False);
   end Item;


   procedure Set_Result (Object : in out Test; Outcome : in Result) is
   begin
      Object.Outcome := Outcome;
   end Set_Result;


   procedure Info (Object : in out Test; Text : in String) is
   begin
      Object.Info.Append (Text);
   end Info;


   procedure Report_Exception
     (Object : in out Test;
      Ex     : in Ada.Exceptions.Exception_Occurrence;
      Code   : in Result := Error) is
   begin
      Set_Result (Object, Code);
      Info
        (Object,
         "Exception " & Ada.Exceptions.Exception_Name (Ex) & " raised:");
      Info (Object, Ada.Exceptions.Exception_Message (Ex));
   end Report_Exception;


   procedure Fail (Object : in out Test; Text : in String := "") is
   begin
      Set_Result (Object, Fail);
      if Text /= "" then
         Info (Object, Text);
      end if;
   end Fail;


   procedure Error (Object : in out Test; Text : in String := "") is
   begin
      Set_Result (Object, Error);
      if Text /= "" then
         Info (Object, Text);
      end if;
   end Error;


   procedure Skip (Object : in out Test; Text : in String := "") is
   begin
      Set_Result (Object, Skipped);
      if Text /= "" then
         Info (Object, Text);
      end if;
   end Skip;


   overriding procedure Finalize (Object : in out Test) is
      Cursor : Info_Lists.Cursor;
   begin
      if not Object.Finalized then
         Object.Finalized := True;
         Object.Report.Item
           (Ada.Strings.Unbounded.To_String (Object.Name),
            Object.Outcome);
         Cursor := Object.Info.First;
         while Info_Lists.Has_Element (Cursor) loop
            Object.Report.Info (Info_Lists.Element (Cursor));
            Info_Lists.Next (Cursor);
         end loop;
      end if;
   end Finalize;

end Natools.Tests;

--                                                                          --
-- Tests are gathered into sections, which can be nested. What a section    --
-- exactly means is left to the implementation of this interface.           --
------------------------------------------------------------------------------

with Ada.Exceptions;

private with Ada.Finalization;
private with Ada.Strings.Unbounded;
private with Ada.Containers.Indefinite_Doubly_Linked_Lists;

package Natools.Tests is
   pragma Preelaborate (Tests);

   type Reporter is interface;
   type Result is (Success, Fail, Error, Skipped);
   type Result_Summary is array (Result) of Natural;

     (Report    : in out Reporter'Class;
      Test_Name : String;
      Ex        : Ada.Exceptions.Exception_Occurrence;
      Code      : Result := Error);
      --  Append to Report a new Item, whose result is Code, along with
      --    a description of the exception Ex as Info entries.


   -----------------
   -- Test Object --
   -----------------

   type Test (<>) is tagged limited private;
      --  An object of type Test hold information about a single test.
      --  It contains a reference to a Reporter object, which is filled with
      --  held info when the Test object is finalized.

   function Item
     (Report : access Reporter'Class;
      Name : String;
      Default_Outcome : Result := Success)
     return Test;
      --  Create a new Test object with the given Name

   procedure Set_Result (Object : in out Test; Outcome : in Result);
      --  Set the test result

   procedure Info (Object : in out Test; Text : in String);
      --  Append the given text as extra information related to the test

   procedure Report_Exception
     (Object : in out Test;
      Ex     : in Ada.Exceptions.Exception_Occurrence;
      Code   : in Result := Error);
      --  Append information about Ex to the test and set its result state

   procedure Fail (Object : in out Test; Text : in String := "");
   procedure Error (Object : in out Test; Text : in String := "");
   procedure Skip (Object : in out Test; Text : in String := "");
      --  Set the result state and append Text info in a single call

private

   package Info_Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists
     (String);

   type Test (Report : access Reporter'Class) is
     new Ada.Finalization.Limited_Controlled with record
      Name : Ada.Strings.Unbounded.Unbounded_String;
      Info : Info_Lists.List;
      Outcome : Result;
      Finalized : Boolean := False;
   end record;

   overriding procedure Finalize (Object : in out Test);

end Natools.Tests;