Natools

Check-in [f6d2649c7f]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:natools-tests-text_io: simple implementation of test report
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: f6d2649c7f813c6b344509d77a7573458082695a
User & Date: nat on 2011-11-25 09:27:37
Other Links: manifest | tags
Context
2011-11-25
10:06
natools-getopt_long: native Ada implementation of getopt_long facilities check-in: 704e78d675 user: nat tags: trunk
09:27
natools-tests-text_io: simple implementation of test report check-in: f6d2649c7f user: nat tags: trunk
08:51
natools-tests: light interface for test reports check-in: b81eadc098 user: nat tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Added natools-tests-text_io.adb version [858548f70a]. 









































































































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

------------------------------------------------------------------------------
-- Copyright (c) 2011, 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 Ada.Strings.Fixed;
with Ada.Text_IO;

package body Natools.Tests.Text_IO is

   ------------------------
   -- Helper subprograms --
   ------------------------

   function Indentation (Level : Natural) return String;
      --  Return the indentation string for the given level.

   function Indentation (Report : Text_Reporter) return String;
      --  Return the indentation string for the current level of Report.


   function Indentation (Level : Natural) return String is
      use Ada.Strings.Fixed;
   begin
      return Level * "  ";
   end Indentation;


   function Indentation (Report : Text_Reporter) return String is
   begin
      return Indentation (Natural (Report.Results.Length));
   end Indentation;


   ------------------------
   -- Public subprograms --
   ------------------------

   procedure Section (Report : in out Text_Reporter; Name : String) is
   begin
      Ada.Text_IO.Put_Line (Indentation (Report) & "Section: " & Name);
      Result_Lists.Append (Report.Results, (others => 0));
   end Section;


   procedure End_Section (Report : in out Text_Reporter) is
      Last_Item : Result_Lists.Cursor := Report.Results.Last;
   begin
      Result_Lists.Delete (Report.Results, Last_Item);
   end End_Section;


   procedure Item
     (Report  : in out Text_Reporter;
      Name    : in     String;
      Outcome : in     Result)
   is
      use Ada.Strings.Fixed;

      procedure Process (Position : Result_Lists.Cursor);
      procedure Update (R : in out Result_Summary);

      Indent : constant String := Indentation (Report);
      Text_Size : constant Positive
        := Indent'Length + Name'Length + Max_Result_String_Size + 1;
      Line_Length : constant Natural
        := Natural (Ada.Text_IO.Line_Length);

      procedure Process (Position : Result_Lists.Cursor) is
      begin
         Result_Lists.Update_Element (Report.Results, Position, Update'Access);
      end Process;

      procedure Update (R : in out Result_Summary) is
      begin
         R (Outcome) := R (Outcome) + 1;
      end Update;
   begin
      if Text_Size < Line_Length then
         Ada.Text_IO.Put_Line (Indent & Name
                               & (Line_Length - Text_Size) * " "
                               & Result'Image (Outcome));
      else
         Ada.Text_IO.Put_Line (Indent & Name);
         Ada.Text_IO.Put_Line (Indent & " -> " & Result'Image (Outcome));
      end if;
      Result_Lists.Iterate (Report.Results, Process'Access);
      Report.Total (Outcome) := Report.Total (Outcome) + 1;
   end Item;


   procedure Info (Report : in out Text_Reporter; Text : String) is
      pragma Unreferenced (Report);
   begin
      Ada.Text_IO.Put_Line (Text);
   end Info;


   function Current_Results (Report : Text_Reporter) return Result_Summary is
   begin
      return Result_Lists.Element (Report.Results.Last);
   end Current_Results;

   function Total_Results (Report : Text_Reporter) return Result_Summary is
   begin
      return Report.Total;
   end Total_Results;


   procedure Print_Results (R : Result_Summary) is
      use Ada.Strings.Fixed;
   begin
      for I in R'Range loop
         declare
            Image : constant String := Result'Image (I);
         begin
            Ada.Text_IO.Put_Line
              (Image
              & (Max_Result_String_Size + 1 - Image'Length) * " "
              & Natural'Image (R (I)));
         end;
      end loop;
   end Print_Results;
end Natools.Tests.Text_IO;








Added natools-tests-text_io.ads version [912f4e4ed5].










































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

------------------------------------------------------------------------------
-- Copyright (c) 2011, 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.Tests.Text_IO is a simple implementation of Natools.Tests        --
-- interface. It immediately prints Item and Info to default output using   --
-- Ada.Text_IO facilities. Current and total result summaries are stored    --
-- in a stack using Doubly_Linked_Lists.                                    --
-- Sections are represented by a two-space indentation.                     --
------------------------------------------------------------------------------

private with Ada.Containers.Doubly_Linked_Lists;

package Natools.Tests.Text_IO is

   type Text_Reporter is new Reporter with private;

   procedure Section (Report : in out Text_Reporter; Name : String);
      --  Start a new (sub)section. This prints section header and increments
      --    indentation.

   procedure End_Section (Report : in out Text_Reporter);
      --  End the current (sub)section. This does not output anything, but
      --    decrements the current indentation.

   procedure Item
     (Report  : in out Text_Reporter;
      Name    : in     String;
      Outcome : in     Result);
      --  Output the Item with its outcome. If Line_Length is wide enough,
      --    the outcome is right-aligned on the same line as the test name,
      --    otherwise it is printed below with an additional indentation.

   procedure Info (Report : in out Text_Reporter; Text : String);
      --  Output the Text directly. Association with previous Item is visual.

   function Current_Results (Report : Text_Reporter) return Result_Summary;
      --  Return the number of each result type in the current subsection.

   function Total_Results (Report : Text_Reporter) return Result_Summary;
      --  Return the total number of each result type.


   procedure Print_Results (R : Result_Summary);
      --  Pretty-print the result summary into the default output.

private

   package Result_Lists is
      new Ada.Containers.Doubly_Linked_Lists (Result_Summary);

   type Text_Reporter is new Reporter with record
      Results : Result_Lists.List;
      Total : Result_Summary := (others => 0);
   end record;

end Natools.Tests.Text_IO;













This page was generated in about
0.004s by
Fossil 2.23 [47362306a7] 2023-11-01 18:56:47