Source file mutate.ml
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
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
open Lang
open Il
module Type = Runtime.Type
module Value = Runtime.Value
open Runtime.Testgen_neg
open Envs
open Domain.Lib
open Util.Source
module Mixfix = Domain.Mixfix
module Mixop = Domain.Mixop
type kind = GenFromTyp | MutateList | MixopGroup
let string_of_kind = function
| GenFromTyp -> "GenFromTyp"
| MutateList -> "MutateList"
| MixopGroup -> "MixopGroup"
let ( let* ) = Option.bind
let wrap_value (typ : typ') (value : value') : value =
let vhash = Value.hash_of value in
value $$ (no_region, { vid = -1; typ; vhash })
let wrap_value_opt (typ : typ') (value_opt : value' option) : value option =
Option.map (wrap_value typ) value_opt
let rec gen_from_typ (depth : int) (tdenv : TDEnv.t) (texts : value' list)
(typ : typ) : value option =
if depth <= 0 then None else gen_from_typ' depth tdenv texts typ
and gen_from_typ' (depth : int) (tdenv : TDEnv.t) (texts : value' list)
(typ : typ) : value option =
let depth = depth - 1 in
match typ.it with
| BoolT ->
[ BoolV true; BoolV false ] |> Rand.random_select |> wrap_value_opt typ.it
| NumT `NatT ->
[
NumV (`Nat (Bigint.of_int 1));
NumV (`Nat (Bigint.of_int 4));
NumV (`Nat (Bigint.of_int 6));
NumV (`Nat (Bigint.of_int 8));
]
|> Rand.random_select |> wrap_value_opt typ.it
| NumT `IntT ->
[
NumV (`Int (Bigint.of_int (-2)));
NumV (`Int (Bigint.of_int 0));
NumV (`Int (Bigint.of_int 2));
NumV (`Int (Bigint.of_int 3));
]
|> Rand.random_select |> wrap_value_opt typ.it
| TextT -> texts |> Rand.random_select |> wrap_value_opt typ.it
| VarT (tid, targs) -> (
let td = TDEnv.find_opt tid tdenv in
match td with
| Some (Defined (tparams, td)) -> (
let theta = List.combine tparams targs |> TDEnv.of_list in
match td.it with
| PlainT typ ->
typ |> Type.Subst.subst_typ theta
|> gen_from_typ depth tdenv texts
| StructT typfields ->
let atoms, typs = List.split typfields in
let* values =
typs
|> Type.Subst.subst_typs theta
|> gen_from_typs depth tdenv texts
in
let valuefields = List.combine atoms values in
StructV valuefields |> Option.some |> wrap_value_opt typ.it
| VariantT typcases ->
let nottyps' =
typcases
|> List.map (fun (nottyp, _, _) ->
Mixfix.map (Type.Subst.subst_typ theta) nottyp.it)
in
let expand_nottyp' nottyp' =
let mixop, typs = Mixfix.split nottyp' in
let* values = gen_from_typs depth tdenv texts typs in
CaseV (Mixfix.fill mixop values) |> Option.some
in
List.map expand_nottyp' nottyps'
|> List.filter Option.is_some |> List.map Option.get
|> Rand.random_select |> wrap_value_opt typ.it)
| _ -> None)
| TupleT typs_inner ->
let* values_inner = gen_from_typs depth tdenv texts typs_inner in
TupleV values_inner |> Option.some |> wrap_value_opt typ.it
| IterT (_, Opt) when depth = 0 ->
OptV None |> Option.some |> wrap_value_opt typ.it
| IterT (typ_inner, Opt) ->
let choices : value' option list =
[
OptV None |> Option.some;
(let* value_inner = gen_from_typ depth tdenv texts typ_inner in
OptV (Some value_inner) |> Option.some);
]
in
let* choice =
choices |> List.filter Option.is_some |> Rand.random_select
in
choice |> wrap_value_opt typ.it
| IterT (_, List) when depth = 0 ->
ListV [] |> Option.some |> wrap_value_opt typ.it
| IterT (typ_inner, List) ->
let len = Random.int 3 in
let* values_inner =
List.init len (fun _ -> typ_inner) |> gen_from_typs depth tdenv texts
in
ListV values_inner |> Option.some |> wrap_value_opt typ.it
| FuncT _ -> None
and gen_from_typs (depth : int) (tdenv : TDEnv.t) (texts : value' list)
(typs : typ list) : value list option =
if depth <= 0 then None
else
List.fold_left
(fun values_opt typ ->
let* values = values_opt in
let* value = gen_from_typ depth tdenv texts typ in
Some (values @ [ value ]))
(Some []) typs
let mutate_type_driven (tdenv : TDEnv.t) (texts : value' list) (value : value) :
(kind * value) option =
let typ = value.note.typ $ no_region in
let depth = Random.int 4 + 1 in
let value_opt = gen_from_typ depth tdenv texts typ in
Option.map (fun value -> (GenFromTyp, value)) value_opt
let mutate_mixop (mixopenv : MixopEnv.t) (value : value) : (kind * value) option
=
let typ = value.note.typ in
match typ with
| VarT (id, _) -> (
match value.it with
| CaseV valuecase ->
let mixop, values = Mixfix.split valuecase in
let* mixop_family = MixopEnv.find_opt id mixopenv in
let mixop_family =
Mixops.Family.filter
(fun mixop_group -> MixIdSet.exists (Mixop.eq mixop) mixop_group)
mixop_family
in
let* mixop_group =
if Mixops.Family.cardinal mixop_family = 0 then None
else mixop_family |> Mixops.Family.choose |> Option.some
in
let* mixop =
mixop_group
|> MixIdSet.filter (fun mixop_e -> not (Mixop.eq mixop mixop_e))
|> MixIdSet.elements |> Rand.random_select
in
let value = CaseV (Mixfix.fill mixop values) |> wrap_value typ in
(MixopGroup, value) |> Option.some
| _ -> assert false)
| _ -> assert false
let rec shuffle_list' (value : value) : value =
let typ = value.note.typ in
match value.it with
| BoolV _ | NumV _ | TextV _ -> value.it |> wrap_value typ
| StructV valuefields ->
let atoms, values = List.split valuefields in
let values_shuffled = List.map shuffle_list' values in
let valuefields_shuffled = List.combine atoms values_shuffled in
StructV valuefields_shuffled |> wrap_value typ
| CaseV valuecase ->
let valuecase_shuffled = Mixfix.map shuffle_list' valuecase in
CaseV valuecase_shuffled |> wrap_value typ
| TupleV values ->
let values_shuffled = List.map shuffle_list' values in
TupleV values_shuffled |> wrap_value typ
| OptV None -> value.it |> wrap_value typ
| OptV (Some value) ->
let value_shuffled = shuffle_list' value in
OptV (Some value_shuffled) |> wrap_value typ
| ListV values ->
let values_shuffled = Rand.shuffle values in
ListV values_shuffled |> wrap_value typ
| FuncV _ | ExternV _ -> value.it |> wrap_value typ
let shuffle_list (value : value) : value option =
let value_shuffled = shuffle_list' value in
if Value.eq value value_shuffled then None else Some value_shuffled
let rec duplicate_list' (value : value) : value =
let typ = value.note.typ in
match value.it with
| BoolV _ | NumV _ | TextV _ -> value.it |> wrap_value typ
| StructV valuefields ->
let atoms, values = List.split valuefields in
let values_duplicated = List.map duplicate_list' values in
let valuefields_duplicated = List.combine atoms values_duplicated in
StructV valuefields_duplicated |> wrap_value typ
| CaseV valuecase ->
let valuecase_duplicated = Mixfix.map duplicate_list' valuecase in
CaseV valuecase_duplicated |> wrap_value typ
| TupleV values ->
let values_duplicated = List.map duplicate_list' values in
TupleV values_duplicated |> wrap_value typ
| OptV None -> value.it |> wrap_value typ
| OptV (Some value) ->
let value_duplicated = duplicate_list' value in
OptV (Some value_duplicated) |> wrap_value typ
| ListV values -> (
match Rand.random_select values with
| Some value ->
let values = value :: values in
ListV values |> wrap_value typ
| None -> value.it |> wrap_value typ)
| FuncV _ | ExternV _ -> value.it |> wrap_value typ
let duplicate_list (value : value) : value option =
let value_duplicated = duplicate_list' value in
if Value.eq value value_duplicated then None else Some value_duplicated
let rec shrink_list' (value : value) : value =
let typ = value.note.typ in
match value.it with
| BoolV _ | NumV _ | TextV _ -> value.it |> wrap_value typ
| StructV valuefields ->
let atoms, values = List.split valuefields in
let values_shrinked = List.map shrink_list' values in
let valuefields_shrinked = List.combine atoms values_shrinked in
StructV valuefields_shrinked |> wrap_value typ
| CaseV valuecase ->
let valuecase_shrinked = Mixfix.map shrink_list' valuecase in
CaseV valuecase_shrinked |> wrap_value typ
| TupleV values ->
let values_shrinked = List.map shrink_list' values in
TupleV values_shrinked |> wrap_value typ
| OptV None -> value.it |> wrap_value typ
| OptV (Some value) ->
let value_shrinked = shrink_list' value in
OptV (Some value_shrinked) |> wrap_value typ
| ListV [] -> value.it |> wrap_value typ
| ListV values ->
let size = Random.int (List.length values) in
let values = Rand.random_sample size values in
ListV values |> wrap_value typ
| FuncV _ | ExternV _ -> value.it |> wrap_value typ
let shrink_list (value : value) : value option =
let value_shrinked = shrink_list' value in
if Value.eq value value_shrinked then None else Some value_shrinked
let mutate_list (value : value) : (kind * value) option =
let wrap_kind (value_opt : value option) : (kind * value) option =
Option.map (fun value -> (MutateList, value)) value_opt
in
let mutations_list =
[
(fun () -> shuffle_list value |> wrap_kind);
(fun () -> duplicate_list value |> wrap_kind);
(fun () -> shrink_list value |> wrap_kind);
]
in
let* mutation = Rand.random_select mutations_list in
mutation ()
let mutate_node (tdenv : TDEnv.t) (mixopenv : MixopEnv.t) (texts : value' list)
(value : value) : (kind * value) option =
match value.it with
| ListV _ ->
let* mutation =
[
(fun () -> mutate_list value);
(fun () -> mutate_type_driven tdenv texts value);
]
|> Rand.random_select
in
mutation ()
| CaseV _ ->
let* mutation =
[
(fun () -> mutate_mixop mixopenv value);
(fun () -> mutate_type_driven tdenv texts value);
]
|> Rand.random_select
in
mutation ()
| _ -> mutate_type_driven tdenv texts value
let mutate_walk (tdenv : TDEnv.t) (mixopenv : MixopEnv.t) (texts : value' list)
(value : value) : (kind * value) option =
let key_max = ref min_float in
let path_best = ref [] in
let rec traverse (path : int list) (value : value) (depth : int) : unit =
let weight = 1.0 /. (float_of_int (depth + 1) ** 3.0) in
let u = Random.float 1.0 in
let key = u ** (1.0 /. weight) in
if key > !key_max then (
key_max := key;
path_best := List.rev path);
match value.it with
| BoolV _ | NumV _ | TextV _ | OptV _ | FuncV _ | ExternV _ -> ()
| StructV valuefields ->
List.iteri
(fun idx (_, value) -> traverse (idx :: path) value (depth + 1))
valuefields
| CaseV valuecase ->
let values = Mixfix.args valuecase in
List.iteri
(fun idx value -> traverse (idx :: path) value (depth + 1))
values
| TupleV values | ListV values ->
List.iteri
(fun idx value -> traverse (idx :: path) value (depth + 1))
values
in
traverse [] value 0;
let kind_found = ref None in
let rec rebuild (path : int list) (value : value) : value option =
let typ = value.note.typ in
match (path, value) with
| [], value ->
let* kind, value = mutate_node tdenv mixopenv texts value in
kind_found := kind |> Option.some;
value |> Option.some
| idx :: path, value -> (
match value.it with
| BoolV _ | NumV _ | TextV _ | OptV _ | FuncV _ | ExternV _ ->
value.it |> wrap_value typ |> Option.some
| StructV valuefields ->
let atoms, values = List.split valuefields in
let* values = rebuilds path idx values in
let valuefields = List.combine atoms values in
StructV valuefields |> wrap_value typ |> Option.some
| CaseV valuecase ->
let mixop, values = Mixfix.split valuecase in
let* values = rebuilds path idx values in
CaseV (Mixfix.fill mixop values) |> wrap_value typ |> Option.some
| TupleV values ->
let* values = rebuilds path idx values in
TupleV values |> wrap_value typ |> Option.some
| ListV values ->
let* values = rebuilds path idx values in
ListV values |> wrap_value typ |> Option.some)
and rebuilds rest i (values_inner : value list) : value list option =
values_inner
|> List.mapi (fun j value ->
if j = i then rebuild rest value else Some value)
|> List.fold_left
(fun values_opt value ->
let* values = values_opt in
let* value = value in
Some (values @ [ value ]))
(Some [])
in
let* value = rebuild !path_best value in
let* kind = !kind_found in
Some (kind, value)
let find_parent (vdg : Dep.Graph.t) (vid_source : vid) : vid option =
let parents =
match Dep.Graph.G.find_opt vdg.edges vid_source with
| None -> []
| Some edges ->
Dep.Edges.E.fold
(fun (label, vid_target) () acc ->
if label = Dep.Edges.Expand then vid_target :: acc else acc)
edges []
in
assert (List.length parents <= 1);
parents |> Rand.random_select
let mutate (tdenv : TDEnv.t) (mixopenv : MixopEnv.t) (texts : value' list)
(vdg : Dep.Graph.t) (vid_source : vid) : (kind * value * value) option =
let expansions =
[
(fun () -> find_parent vdg vid_source);
(fun () -> vid_source |> Option.some);
]
in
let expansion = Rand.random_select expansions |> Option.get in
let vid_to_mutate =
match expansion () with Some vid_parent -> vid_parent | None -> vid_source
in
let value_to_mutate =
Dep.Graph.reassemble_graph vdg VIdMap.empty vid_to_mutate
in
let* kind, value_mutated = mutate_walk tdenv mixopenv texts value_to_mutate in
(kind, value_to_mutate, value_mutated) |> Option.some
let mutates (fuel_mutate : int) (tdenv : TDEnv.t) (mixopenv : MixopEnv.t)
(vdg : Dep.Graph.t) (vid_source : vid) : (kind * value * value) list =
let texts =
List.init (vdg.root + 1) Fun.id
|> List.filter_map (fun vid ->
let* mirror, _ = Dep.Graph.find_node vdg vid in
match mirror.it with TextN text -> Some (TextV text) | _ -> None)
in
let texts = texts @ [ TextV "lazy"; TextV "fox" ] in
List.init fuel_mutate (fun _ -> mutate tdenv mixopenv texts vdg vid_source)
|> List.filter_map Fun.id