34965
|
1 |
(*
|
|
2 |
Title: HOL/Mutabelle/mutabelle_extra.ML
|
|
3 |
Author: Stefan Berghofer, Jasmin Blanchette, Lukas Bulwahn, TU Muenchen
|
|
4 |
|
|
5 |
Invokation of Counterexample generators
|
|
6 |
*)
|
|
7 |
signature MUTABELLE_EXTRA =
|
|
8 |
sig
|
|
9 |
|
|
10 |
val take_random : int -> 'a list -> 'a list
|
|
11 |
|
|
12 |
datatype outcome = GenuineCex | PotentialCex | NoCex | Donno | Timeout | Error
|
|
13 |
type mtd = string * (theory -> term -> outcome)
|
|
14 |
|
|
15 |
type mutant_subentry = term * (string * outcome) list
|
|
16 |
type detailed_entry = string * bool * term * mutant_subentry list
|
|
17 |
|
|
18 |
type subentry = string * int * int * int * int * int * int
|
|
19 |
type entry = string * bool * subentry list
|
|
20 |
type report = entry list
|
|
21 |
|
|
22 |
val quickcheck_mtd : string -> mtd
|
|
23 |
(*
|
|
24 |
val refute_mtd : mtd
|
|
25 |
val nitpick_mtd : mtd
|
|
26 |
*)
|
|
27 |
|
|
28 |
val freezeT : term -> term
|
|
29 |
val thms_of : bool -> theory -> thm list
|
|
30 |
|
|
31 |
val string_for_report : report -> string
|
|
32 |
val write_report : string -> report -> unit
|
|
33 |
val mutate_theorems_and_write_report :
|
|
34 |
theory -> mtd list -> thm list -> string -> unit
|
|
35 |
|
|
36 |
val random_seed : real Unsynchronized.ref
|
|
37 |
end;
|
|
38 |
|
|
39 |
structure MutabelleExtra : MUTABELLE_EXTRA =
|
|
40 |
struct
|
|
41 |
|
|
42 |
(* Own seed; can't rely on the Isabelle one to stay the same *)
|
|
43 |
val random_seed = Unsynchronized.ref 1.0;
|
|
44 |
|
|
45 |
|
|
46 |
(* mutation options *)
|
|
47 |
val max_mutants = 4
|
|
48 |
val num_mutations = 1
|
|
49 |
(* soundness check: *)
|
|
50 |
val max_mutants = 1
|
|
51 |
val num_mutations = 0
|
|
52 |
|
|
53 |
(* quickcheck options *)
|
|
54 |
(*val quickcheck_generator = "SML"*)
|
|
55 |
val iterations = 100
|
|
56 |
val size = 5
|
|
57 |
|
|
58 |
exception RANDOM;
|
|
59 |
|
|
60 |
fun rmod x y = x - y * Real.realFloor (x / y);
|
|
61 |
|
|
62 |
local
|
|
63 |
val a = 16807.0;
|
|
64 |
val m = 2147483647.0;
|
|
65 |
in
|
|
66 |
|
|
67 |
fun random () = CRITICAL (fn () =>
|
|
68 |
let val r = rmod (a * ! random_seed) m
|
|
69 |
in (random_seed := r; r) end);
|
|
70 |
|
|
71 |
end;
|
|
72 |
|
|
73 |
fun random_range l h =
|
|
74 |
if h < l orelse l < 0 then raise RANDOM
|
|
75 |
else l + Real.floor (rmod (random ()) (real (h - l + 1)));
|
|
76 |
|
|
77 |
datatype outcome = GenuineCex | PotentialCex | NoCex | Donno | Timeout | Error
|
|
78 |
type mtd = string * (theory -> term -> outcome)
|
|
79 |
|
|
80 |
type mutant_subentry = term * (string * outcome) list
|
|
81 |
type detailed_entry = string * bool * term * mutant_subentry list
|
|
82 |
|
|
83 |
|
|
84 |
type subentry = string * int * int * int * int * int * int
|
|
85 |
type entry = string * bool * subentry list
|
|
86 |
type report = entry list
|
|
87 |
|
|
88 |
fun inst_type insts (Type (s, Ts)) = Type (s, map (inst_type insts) Ts)
|
|
89 |
| inst_type insts T = the_default HOLogic.intT (AList.lookup op = insts T)
|
|
90 |
|
|
91 |
fun preprocess thy insts t = ObjectLogic.atomize_term thy
|
|
92 |
(map_types (inst_type insts) (Mutabelle.freeze t));
|
|
93 |
|
|
94 |
fun invoke_quickcheck quickcheck_generator thy t =
|
|
95 |
TimeLimit.timeLimit (Time.fromSeconds (! Auto_Counterexample.time_limit))
|
|
96 |
(fn _ =>
|
|
97 |
case Quickcheck.test_term (ProofContext.init thy) false (SOME quickcheck_generator)
|
|
98 |
size iterations (preprocess thy [] t) of
|
|
99 |
NONE => NoCex
|
|
100 |
| SOME _ => GenuineCex) ()
|
|
101 |
handle TimeLimit.TimeOut => Timeout
|
|
102 |
|
|
103 |
fun quickcheck_mtd quickcheck_generator =
|
|
104 |
("quickcheck_" ^ quickcheck_generator, invoke_quickcheck quickcheck_generator)
|
|
105 |
|
|
106 |
(*
|
|
107 |
fun invoke_refute thy t =
|
|
108 |
let
|
|
109 |
val res = MyRefute.refute_term thy [] t
|
|
110 |
val _ = priority ("Refute: " ^ res)
|
|
111 |
in
|
|
112 |
case res of
|
|
113 |
"genuine" => GenuineCex
|
|
114 |
| "likely_genuine" => GenuineCex
|
|
115 |
| "potential" => PotentialCex
|
|
116 |
| "none" => NoCex
|
|
117 |
| "unknown" => Donno
|
|
118 |
| _ => Error
|
|
119 |
end
|
|
120 |
handle MyRefute.REFUTE (loc, details) =>
|
|
121 |
(error ("Unhandled Refute error (" ^ quote loc ^ "): " ^ details ^
|
|
122 |
"."))
|
|
123 |
val refute_mtd = ("refute", invoke_refute)
|
|
124 |
*)
|
|
125 |
|
|
126 |
(*
|
|
127 |
open Nitpick_Util
|
|
128 |
open Nitpick_Rep
|
|
129 |
open Nitpick_Nut
|
|
130 |
|
|
131 |
fun invoke_nitpick thy t =
|
|
132 |
let
|
|
133 |
val ctxt = ProofContext.init thy
|
|
134 |
val state = Proof.init ctxt
|
|
135 |
in
|
|
136 |
let
|
|
137 |
val (res, _) = Nitpick.pick_nits_in_term state (Nitpick_Isar.default_params thy []) false [] t
|
|
138 |
val _ = priority ("Nitpick: " ^ res)
|
|
139 |
in
|
|
140 |
case res of
|
|
141 |
"genuine" => GenuineCex
|
|
142 |
| "likely_genuine" => GenuineCex
|
|
143 |
| "potential" => PotentialCex
|
|
144 |
| "none" => NoCex
|
|
145 |
| "unknown" => Donno
|
|
146 |
| _ => Error
|
|
147 |
end
|
|
148 |
handle ARG (loc, details) =>
|
|
149 |
(error ("Bad argument(s) to " ^ quote loc ^ ": " ^ details ^ "."))
|
|
150 |
| BAD (loc, details) =>
|
|
151 |
(error ("Internal error (" ^ quote loc ^ "): " ^ details ^ "."))
|
|
152 |
| LIMIT (_, details) =>
|
|
153 |
(warning ("Limit reached: " ^ details ^ "."); Donno)
|
|
154 |
| NOT_SUPPORTED details =>
|
|
155 |
(warning ("Unsupported case: " ^ details ^ "."); Donno)
|
|
156 |
| NUT (loc, us) =>
|
|
157 |
(error ("Invalid nut" ^ plural_s_for_list us ^
|
|
158 |
" (" ^ quote loc ^ "): " ^
|
|
159 |
commas (map (string_for_nut ctxt) us) ^ "."))
|
|
160 |
| REP (loc, Rs) =>
|
|
161 |
(error ("Invalid representation" ^ plural_s_for_list Rs ^
|
|
162 |
" (" ^ quote loc ^ "): " ^
|
|
163 |
commas (map string_for_rep Rs) ^ "."))
|
|
164 |
| TERM (loc, ts) =>
|
|
165 |
(error ("Invalid term" ^ plural_s_for_list ts ^
|
|
166 |
" (" ^ quote loc ^ "): " ^
|
|
167 |
commas (map (Syntax.string_of_term ctxt) ts) ^ "."))
|
|
168 |
| TYPE (loc, Ts, ts) =>
|
|
169 |
(error ("Invalid type" ^ plural_s_for_list Ts ^
|
|
170 |
(if null ts then
|
|
171 |
""
|
|
172 |
else
|
|
173 |
" for term" ^ plural_s_for_list ts ^ " " ^
|
|
174 |
commas (map (quote o Syntax.string_of_term ctxt) ts)) ^
|
|
175 |
" (" ^ quote loc ^ "): " ^
|
|
176 |
commas (map (Syntax.string_of_typ ctxt) Ts) ^ "."))
|
|
177 |
| Kodkod.SYNTAX (_, details) =>
|
|
178 |
(warning ("Ill-formed Kodkodi output: " ^ details ^ "."); Error)
|
|
179 |
| Refute.REFUTE (loc, details) =>
|
|
180 |
(error ("Unhandled Refute error (" ^ quote loc ^ "): " ^ details ^
|
|
181 |
"."))
|
|
182 |
| Exn.Interrupt => raise Exn.Interrupt
|
|
183 |
| _ => (priority ("Unknown error in Nitpick"); Error)
|
|
184 |
end
|
|
185 |
val nitpick_mtd = ("nitpick", invoke_nitpick)
|
|
186 |
*)
|
|
187 |
|
|
188 |
val comms = [@{const_name "op ="}, @{const_name "op |"}, @{const_name "op &"}]
|
|
189 |
|
|
190 |
val forbidden =
|
|
191 |
[(* (@{const_name "power"}, "'a"), *)
|
|
192 |
("HOL.induct_equal", "'a"),
|
|
193 |
("HOL.induct_implies", "'a"),
|
|
194 |
("HOL.induct_conj", "'a"),
|
|
195 |
(@{const_name "undefined"}, "'a"),
|
|
196 |
(@{const_name "default"}, "'a"),
|
|
197 |
(@{const_name "dummy_pattern"}, "'a::{}") (*,
|
|
198 |
(@{const_name "uminus"}, "'a"),
|
|
199 |
(@{const_name "Nat.size"}, "'a"),
|
|
200 |
(@{const_name "HOL.abs"}, "'a") *)]
|
|
201 |
|
|
202 |
val forbidden_thms =
|
|
203 |
["finite_intvl_succ_class",
|
|
204 |
"nibble"]
|
|
205 |
|
|
206 |
val forbidden_consts =
|
|
207 |
[@{const_name nibble_pair_of_char}]
|
|
208 |
|
|
209 |
fun is_forbidden_theorem (s, th) =
|
|
210 |
let val consts = Term.add_const_names (prop_of th) [] in
|
|
211 |
exists (fn s' => s' mem space_explode "." s) forbidden_thms orelse
|
|
212 |
exists (fn s' => s' mem forbidden_consts) consts orelse
|
|
213 |
length (space_explode "." s) <> 2 orelse
|
|
214 |
String.isPrefix "type_definition" (List.last (space_explode "." s)) orelse
|
|
215 |
String.isSuffix "_def" s orelse
|
|
216 |
String.isSuffix "_raw" s
|
|
217 |
end
|
|
218 |
|
|
219 |
fun is_forbidden_mutant t =
|
|
220 |
let val consts = Term.add_const_names t [] in
|
|
221 |
exists (String.isPrefix "Nitpick") consts orelse
|
|
222 |
exists (String.isSubstring "_sumC") consts (* internal function *)
|
|
223 |
end
|
|
224 |
|
|
225 |
fun is_executable_term thy t = can (TimeLimit.timeLimit (Time.fromMilliseconds 2000) (Quickcheck.test_term
|
|
226 |
(ProofContext.init thy) false (SOME "SML") 1 0)) (preprocess thy [] t)
|
|
227 |
fun is_executable_thm thy th = is_executable_term thy (prop_of th)
|
|
228 |
|
|
229 |
val freezeT =
|
|
230 |
map_types (map_type_tvar (fn ((a, i), S) =>
|
|
231 |
TFree (if i = 0 then a else a ^ "_" ^ string_of_int i, S)))
|
|
232 |
|
|
233 |
fun thms_of all thy =
|
|
234 |
filter
|
|
235 |
(fn th => (all orelse Context.theory_name (theory_of_thm th) = Context.theory_name thy)
|
|
236 |
(* andalso is_executable_thm thy th *))
|
|
237 |
(map snd (filter_out is_forbidden_theorem (Mutabelle.all_unconcealed_thms_of thy)))
|
|
238 |
|
|
239 |
val count = length oo filter o equal
|
|
240 |
|
|
241 |
fun take_random 0 _ = []
|
|
242 |
| take_random _ [] = []
|
|
243 |
| take_random n xs =
|
|
244 |
let val j = random_range 0 (length xs - 1) in
|
|
245 |
Library.nth xs j :: take_random (n - 1) (nth_drop j xs)
|
|
246 |
end
|
|
247 |
|
|
248 |
fun safe_invoke_mtd thy (mtd_name, invoke_mtd) t =
|
|
249 |
let
|
|
250 |
val _ = priority ("Invoking " ^ mtd_name)
|
|
251 |
val res = case try (invoke_mtd thy) t of
|
|
252 |
SOME res => res
|
|
253 |
| NONE => (priority ("**** PROBLEMS WITH " ^
|
|
254 |
Syntax.string_of_term_global thy t); Error)
|
|
255 |
val _ = priority (" Done")
|
|
256 |
in res end
|
|
257 |
|
|
258 |
(* theory -> term list -> mtd -> subentry *)
|
|
259 |
fun test_mutants_using_one_method thy mutants (mtd_name, invoke_mtd) =
|
|
260 |
let
|
|
261 |
val res = map (safe_invoke_mtd thy (mtd_name, invoke_mtd)) mutants
|
|
262 |
in
|
|
263 |
(mtd_name, count GenuineCex res, count PotentialCex res, count NoCex res,
|
|
264 |
count Donno res, count Timeout res, count Error res)
|
|
265 |
end
|
|
266 |
|
|
267 |
fun create_entry thy thm exec mutants mtds =
|
|
268 |
(Thm.get_name thm, exec, map (test_mutants_using_one_method thy mutants) mtds)
|
|
269 |
|
|
270 |
fun create_detailed_entry thy thm exec mutants mtds =
|
|
271 |
let
|
|
272 |
fun create_mutant_subentry mutant = (mutant,
|
|
273 |
map (fn (mtd_name, invoke_mtd) =>
|
|
274 |
(mtd_name, safe_invoke_mtd thy (mtd_name, invoke_mtd) mutant)) mtds)
|
|
275 |
in
|
|
276 |
(Thm.get_name thm, exec, prop_of thm, map create_mutant_subentry mutants)
|
|
277 |
end
|
|
278 |
|
|
279 |
(* (theory -> thm -> bool -> term list -> mtd list -> 'a) -> theory -> mtd list -> thm -> 'a *)
|
|
280 |
fun mutate_theorem create_entry thy mtds thm =
|
|
281 |
let
|
|
282 |
val pp = Syntax.pp_global thy
|
|
283 |
val exec = is_executable_thm thy thm
|
|
284 |
val _ = priority (if exec then "EXEC" else "NOEXEC")
|
|
285 |
val mutants =
|
|
286 |
(if num_mutations = 0 then
|
|
287 |
[Thm.prop_of thm]
|
|
288 |
else
|
|
289 |
Mutabelle.mutate_mix (Thm.prop_of thm) thy comms forbidden
|
|
290 |
num_mutations)
|
|
291 |
|> filter_out is_forbidden_mutant
|
|
292 |
val mutants =
|
|
293 |
if exec then
|
|
294 |
let
|
|
295 |
val _ = priority ("BEFORE PARTITION OF " ^
|
|
296 |
Int.toString (length mutants) ^ " MUTANTS")
|
|
297 |
val (execs, noexecs) = List.partition (is_executable_term thy) (take_random (20 * max_mutants) mutants)
|
|
298 |
val _ = tracing ("AFTER PARTITION (" ^ Int.toString (length execs) ^
|
|
299 |
" vs " ^ Int.toString (length noexecs) ^ ")")
|
|
300 |
in
|
|
301 |
execs @ take_random (Int.max (0, max_mutants - length execs)) noexecs
|
|
302 |
end
|
|
303 |
else
|
|
304 |
mutants
|
|
305 |
val mutants = mutants
|
|
306 |
|> take_random max_mutants
|
|
307 |
|> map Mutabelle.freeze |> map freezeT
|
|
308 |
(* |> filter (not o is_forbidden_mutant) *)
|
|
309 |
|> List.mapPartial (try (Sign.cert_term thy))
|
|
310 |
val _ = map (fn t => priority ("MUTANT: " ^ Pretty.string_of (Pretty.term pp t))) mutants
|
|
311 |
in
|
|
312 |
create_entry thy thm exec mutants mtds
|
|
313 |
end
|
|
314 |
|
|
315 |
(* theory -> mtd list -> thm list -> report *)
|
|
316 |
val mutate_theorems = map ooo mutate_theorem
|
|
317 |
|
|
318 |
fun string_of_outcome GenuineCex = "GenuineCex"
|
|
319 |
| string_of_outcome PotentialCex = "PotentialCex"
|
|
320 |
| string_of_outcome NoCex = "NoCex"
|
|
321 |
| string_of_outcome Donno = "Donno"
|
|
322 |
| string_of_outcome Timeout = "Timeout"
|
|
323 |
| string_of_outcome Error = "Error"
|
|
324 |
|
|
325 |
fun string_of_mutant_subentry thy (t, results) =
|
|
326 |
"mutant: " ^ Syntax.string_of_term_global thy t ^ "\n" ^
|
|
327 |
space_implode "; " (map (fn (mtd_name, outcome) => mtd_name ^ ": " ^ string_of_outcome outcome) results) ^
|
|
328 |
"\n"
|
|
329 |
|
|
330 |
fun string_of_detailed_entry thy (thm_name, exec, t, mutant_subentries) =
|
|
331 |
thm_name ^ " " ^ (if exec then "[exe]" else "[noexe]") ^ ": " ^
|
|
332 |
Syntax.string_of_term_global thy t ^ "\n" ^
|
|
333 |
cat_lines (map (string_of_mutant_subentry thy) mutant_subentries) ^ "\n"
|
|
334 |
|
|
335 |
(* subentry -> string *)
|
|
336 |
fun string_for_subentry (mtd_name, genuine_cex, potential_cex, no_cex, donno,
|
|
337 |
timeout, error) =
|
|
338 |
" " ^ mtd_name ^ ": " ^ Int.toString genuine_cex ^ "+ " ^
|
|
339 |
Int.toString potential_cex ^ "= " ^ Int.toString no_cex ^ "- " ^
|
|
340 |
Int.toString donno ^ "? " ^ Int.toString timeout ^ "T " ^
|
|
341 |
Int.toString error ^ "!"
|
|
342 |
(* entry -> string *)
|
|
343 |
fun string_for_entry (thm_name, exec, subentries) =
|
|
344 |
thm_name ^ " " ^ (if exec then "[exe]" else "[noexe]") ^ ":\n" ^
|
|
345 |
cat_lines (map string_for_subentry subentries) ^ "\n"
|
|
346 |
(* report -> string *)
|
|
347 |
fun string_for_report report = cat_lines (map string_for_entry report)
|
|
348 |
|
|
349 |
(* string -> report -> unit *)
|
|
350 |
fun write_report file_name =
|
|
351 |
File.write (Path.explode file_name) o string_for_report
|
|
352 |
|
|
353 |
(* theory -> mtd list -> thm list -> string -> unit *)
|
|
354 |
fun mutate_theorems_and_write_report thy mtds thms file_name =
|
|
355 |
let
|
|
356 |
val _ = priority "Starting Mutabelle..."
|
|
357 |
val path = Path.explode file_name
|
|
358 |
(* for normal report: *)
|
|
359 |
(*val (gen_create_entry, gen_string_for_entry) = (create_entry, string_for_entry)*)
|
|
360 |
(*for detailled report: *)
|
|
361 |
val (gen_create_entry, gen_string_for_entry) =
|
|
362 |
(create_detailed_entry, string_of_detailed_entry thy)
|
|
363 |
in
|
|
364 |
File.write path (
|
|
365 |
"Mutation options = " ^
|
|
366 |
"max_mutants: " ^ string_of_int max_mutants ^
|
|
367 |
"; num_mutations: " ^ string_of_int num_mutations ^ "\n" ^
|
|
368 |
"QC options = " ^
|
|
369 |
(*"quickcheck_generator: " ^ quickcheck_generator ^ ";*)
|
|
370 |
"size: " ^ string_of_int size ^
|
|
371 |
"; iterations: " ^ string_of_int iterations ^ "\n");
|
|
372 |
map (File.append path o gen_string_for_entry o mutate_theorem gen_create_entry thy mtds) thms;
|
|
373 |
()
|
|
374 |
end
|
|
375 |
|
|
376 |
end;
|