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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187 | ------------------------------------------------------------------------------
-- --
-- TGen --
-- --
-- Copyright (C) 2022, AdaCore --
-- --
-- TGen is free software; you can redistribute it and/or modify it under --
-- under terms of the GNU General Public License as published by the --
-- Free Software Foundation; either version 3, or (at your option) any --
-- later version. This software is distributed in the hope that it will be --
-- useful but WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are --
-- granted additional permissions described in the GCC Runtime Library --
-- Exception, version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and a --
-- copy of the GCC Runtime Library Exception along with this program; see --
-- the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--
-- Random value generation strategies. For the moment this concerns only
-- static generation strategies, but will also be applicable to dynamic
-- generation later on.
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Containers.Vectors;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Strings.Unbounded.Hash;
with TGen.JSON; use TGen.JSON;
with TGen.Strings; use TGen.Strings;
with TGen.Types; use TGen.Types;
package TGen.Strategies is
type Strategy_Kind is
(Random_Kind, State_Kind, Dispatching_Kind, Wrapping_Kind);
package Disc_Value_Maps is new Ada.Containers.Indefinite_Hashed_Maps
(Key_Type => Unbounded_String,
Element_Type => JSON_Value,
Hash => Ada.Strings.Unbounded.Hash,
Equivalent_Keys => "=",
"=" => TGen.JSON."=");
subtype Disc_Value_Map is Disc_Value_Maps.Map;
type Strategy_Type is abstract tagged null record;
procedure Init (S : in out Strategy_Type) is null;
function Has_Next (S : Strategy_Type) return Boolean is abstract;
-- Whether this strategy can generate a value
function Generate
(S : in out Strategy_Type;
Disc_Context : Disc_Value_Map) return JSON_Value
is abstract;
-- Requires S.Has_Next. Yields a new element, using stateful information
-- contained in S if needed. Disc_Context contains the values for the
-- discriminants if this is in a discriminated record generation context.
--
-- Note that the generated JSON value is un-encoded according to S. This
-- means, for discrete values, that the generated JSON value should be of
-- kind Integer, instead of their stringified version, so it can be reused
-- more efficiently in other contexts. The values generated by this will be
-- converted to something parsable through the Encode primitive of the
-- corresponding type representation.
type Random_Strategy_Type is abstract new Strategy_Type with null record;
function Has_Next (S : Random_Strategy_Type) return Boolean is (True);
-- A random strategy can always generate values
type Strategy_Acc is access all Strategy_Type'Class;
type Unimplemented_Strategy_Type is new Strategy_Type with
null record;
overriding function Generate
(S : in out Unimplemented_Strategy_Type;
Disc_Context : Disc_Value_Map) return JSON_Value
is
(raise Program_Error with "Unimplemented static strategy");
overriding function Has_Next
(S : Unimplemented_Strategy_Type) return Boolean
is (False);
type Commented_Out_Strategy_Type is new Strategy_Type with
null record;
-- Strategy that generates comments stating that the user should fill in
-- a valid value.
overriding function Generate
(S : in out Commented_Out_Strategy_Type;
Disc_Context : Disc_Value_Map) return JSON_Value;
overriding function Has_Next
(S : Commented_Out_Strategy_Type) return Boolean
is (True);
type Basic_Strategy_Type is new Random_Strategy_Type with record
T : SP.Ref;
-- A generic strategy will always need to store the type it references,
-- to do introspection and know, e.g. the bounds of the type if it is a
-- scalar type.
F : access function (T : Typ'Class) return JSON_Value;
-- The actual generation function. See below the instantiation of the
-- Generate function.
end record;
overriding function Generate
(S : in out Basic_Strategy_Type;
Disc_Context : Disc_Value_Map) return JSON_Value
is
(S.F (S.T.Get));
type Dispatching_Strategy_Type is new Random_Strategy_Type with
record
Bias : Float;
S1, S2 : Strategy_Acc;
end record;
-- This strategy dispatches the generation to two strategies, according
-- to a certain bias. This is useful when mixing two strategies.
overriding function Generate
(S : in out Dispatching_Strategy_Type;
Disc_Context : Disc_Value_Map) return JSON_Value;
overriding function Has_Next
(S : Dispatching_Strategy_Type) return Boolean
is (S.S1.Has_Next or else S.S2.Has_Next);
function Make_Dispatching_Strat
(S1, S2 : Strategy_Type'Class;
Bias : Float := 0.5) return Dispatching_Strategy_Type;
generic
type Equivalence_Class_Type is private;
with package Equivalence_Classes_Vectors is
new Ada.Containers.Vectors
(Index_Type => Positive, Element_Type => Equivalence_Class_Type);
package Equivalence_Classes_Strategy_Package is
type Equivalence_Class_Strategy_Type is new Random_Strategy_Type with
record
T : SP.Ref;
Classes : Equivalence_Classes_Vectors.Vector;
Draw : access function
(T : SP.Ref;
Class : Equivalence_Class_Type) return JSON_Value;
end record;
-- This strategy implements equivalence classes strategy, i.e.
-- strategies where we will pick in an equivalence class each time
-- we are generating a value. Note that we can pick several time a value
-- from the same equivalence class. TODO: fix this?
overriding function Generate
(S : in out Equivalence_Class_Strategy_Type;
Disc_Context : Disc_Value_Map) return JSON_Value;
end Equivalence_Classes_Strategy_Package;
function "=" (L, R : Strategy_Type'Class) return Boolean;
-- It makes no sense to define an equality operator for strategy, and we
-- need one to implement record strategies (to map a component type to
-- its strategy). Make a function that always return False.
type Enum_Strategy_Type is abstract new Strategy_Type with null record;
type Enum_Strategy_Type_Acc is access all Enum_Strategy_Type'Class;
procedure Init (S : in out Enum_Strategy_Type) is abstract;
-- Initial state for this enumerative strategy
function Has_Next (S : Enum_Strategy_Type) return Boolean is abstract;
-- Whether another element can be produced by this strategy
function Generate
(S : in out Enum_Strategy_Type;
Disc_Context : Disc_Value_Map) return JSON_Value is abstract with
Pre'Class => S.Has_Next;
-- Yields a new element, using stateful information contained in S
end TGen.Strategies;
|