2 Title: HOL/Mutabelle/mutabelle_extra.ML
3 Author: Stefan Berghofer, Jasmin Blanchette, Lukas Bulwahn, TU Muenchen
5 Invokation of Counterexample generators
7 signature MUTABELLE_EXTRA =
10 val take_random : int -> 'a list -> 'a list
12 datatype outcome = GenuineCex | PotentialCex | NoCex | Donno | Timeout | Error
13 type timing = (string * int) list
15 type mtd = string * (theory -> term -> outcome * (timing * (int * Quickcheck.report list) list option))
17 type mutant_subentry = term * (string * (outcome * (timing * Quickcheck.report option))) list
18 type detailed_entry = string * bool * term * mutant_subentry list
20 type subentry = string * int * int * int * int * int * int
21 type entry = string * bool * subentry list
22 type report = entry list
24 val quickcheck_mtd : string -> mtd
30 val freezeT : term -> term
31 val thms_of : bool -> theory -> thm list
33 val string_for_report : report -> string
34 val write_report : string -> report -> unit
35 val mutate_theorems_and_write_report :
36 theory -> mtd list -> thm list -> string -> unit
38 val random_seed : real Unsynchronized.ref
41 structure MutabelleExtra : MUTABELLE_EXTRA =
44 (* Own seed; can't rely on the Isabelle one to stay the same *)
45 val random_seed = Unsynchronized.ref 1.0;
48 (* mutation options *)
51 (* soundness check: *)
55 (* quickcheck options *)
56 (*val quickcheck_generator = "SML"*)
62 fun rmod x y = x - y * Real.realFloor (x / y);
69 fun random () = CRITICAL (fn () =>
70 let val r = rmod (a * ! random_seed) m
71 in (random_seed := r; r) end);
75 fun random_range l h =
76 if h < l orelse l < 0 then raise RANDOM
77 else l + Real.floor (rmod (random ()) (real (h - l + 1)));
79 datatype outcome = GenuineCex | PotentialCex | NoCex | Donno | Timeout | Error
80 type timing = (string * int) list
82 type mtd = string * (theory -> term -> outcome * (timing * (int * Quickcheck.report list) list option))
84 type mutant_subentry = term * (string * (outcome * (timing * Quickcheck.report option))) list
85 type detailed_entry = string * bool * term * mutant_subentry list
87 type subentry = string * int * int * int * int * int * int
88 type entry = string * bool * subentry list
89 type report = entry list
91 fun inst_type insts (Type (s, Ts)) = Type (s, map (inst_type insts) Ts)
92 | inst_type insts T = the_default HOLogic.intT (AList.lookup op = insts T)
94 fun preprocess thy insts t = Object_Logic.atomize_term thy
95 (map_types (inst_type insts) (Mutabelle.freeze t));
97 fun invoke_quickcheck quickcheck_generator thy t =
98 TimeLimit.timeLimit (Time.fromSeconds (! Auto_Counterexample.time_limit))
100 case Quickcheck.gen_test_term (ProofContext.init thy) true true (SOME quickcheck_generator)
101 size iterations (preprocess thy [] t) of
102 (NONE, (time_report, report)) => (NoCex, (time_report, report))
103 | (SOME _, (time_report, report)) => (GenuineCex, (time_report, report))) ()
104 handle TimeLimit.TimeOut => (Timeout, ([("timelimit", !Auto_Counterexample.time_limit)], NONE))
106 fun quickcheck_mtd quickcheck_generator =
107 ("quickcheck_" ^ quickcheck_generator, invoke_quickcheck quickcheck_generator)
110 fun invoke_refute thy t =
112 val res = MyRefute.refute_term thy [] t
113 val _ = priority ("Refute: " ^ res)
116 "genuine" => GenuineCex
117 | "likely_genuine" => GenuineCex
118 | "potential" => PotentialCex
123 handle MyRefute.REFUTE (loc, details) =>
124 (error ("Unhandled Refute error (" ^ quote loc ^ "): " ^ details ^
126 val refute_mtd = ("refute", invoke_refute)
134 fun invoke_nitpick thy t =
136 val ctxt = ProofContext.init thy
137 val state = Proof.init ctxt
140 val (res, _) = Nitpick.pick_nits_in_term state (Nitpick_Isar.default_params thy []) false [] t
141 val _ = priority ("Nitpick: " ^ res)
144 "genuine" => GenuineCex
145 | "likely_genuine" => GenuineCex
146 | "potential" => PotentialCex
151 handle ARG (loc, details) =>
152 (error ("Bad argument(s) to " ^ quote loc ^ ": " ^ details ^ "."))
153 | BAD (loc, details) =>
154 (error ("Internal error (" ^ quote loc ^ "): " ^ details ^ "."))
155 | LIMIT (_, details) =>
156 (warning ("Limit reached: " ^ details ^ "."); Donno)
157 | NOT_SUPPORTED details =>
158 (warning ("Unsupported case: " ^ details ^ "."); Donno)
160 (error ("Invalid nut" ^ plural_s_for_list us ^
161 " (" ^ quote loc ^ "): " ^
162 commas (map (string_for_nut ctxt) us) ^ "."))
164 (error ("Invalid representation" ^ plural_s_for_list Rs ^
165 " (" ^ quote loc ^ "): " ^
166 commas (map string_for_rep Rs) ^ "."))
168 (error ("Invalid term" ^ plural_s_for_list ts ^
169 " (" ^ quote loc ^ "): " ^
170 commas (map (Syntax.string_of_term ctxt) ts) ^ "."))
171 | TYPE (loc, Ts, ts) =>
172 (error ("Invalid type" ^ plural_s_for_list Ts ^
176 " for term" ^ plural_s_for_list ts ^ " " ^
177 commas (map (quote o Syntax.string_of_term ctxt) ts)) ^
178 " (" ^ quote loc ^ "): " ^
179 commas (map (Syntax.string_of_typ ctxt) Ts) ^ "."))
180 | Kodkod.SYNTAX (_, details) =>
181 (warning ("Ill-formed Kodkodi output: " ^ details ^ "."); Error)
182 | Refute.REFUTE (loc, details) =>
183 (error ("Unhandled Refute error (" ^ quote loc ^ "): " ^ details ^
185 | Exn.Interrupt => raise Exn.Interrupt
186 | _ => (priority ("Unknown error in Nitpick"); Error)
188 val nitpick_mtd = ("nitpick", invoke_nitpick)
191 val comms = [@{const_name "op ="}, @{const_name "op |"}, @{const_name "op &"}]
194 [(* (@{const_name "power"}, "'a"), *)
195 (*(@{const_name induct_equal}, "'a"),
196 (@{const_name induct_implies}, "'a"),
197 (@{const_name induct_conj}, "'a"),*)
198 (@{const_name "undefined"}, "'a"),
199 (@{const_name "default"}, "'a"),
200 (@{const_name "dummy_pattern"}, "'a::{}") (*,
201 (@{const_name "uminus"}, "'a"),
202 (@{const_name "Nat.size"}, "'a"),
203 (@{const_name "Groups.abs"}, "'a") *)]
206 ["finite_intvl_succ_class",
209 val forbidden_consts =
210 [@{const_name nibble_pair_of_char}]
212 fun is_forbidden_theorem (s, th) =
213 let val consts = Term.add_const_names (prop_of th) [] in
214 exists (fn s' => s' mem space_explode "." s) forbidden_thms orelse
215 exists (fn s' => s' mem forbidden_consts) consts orelse
216 length (space_explode "." s) <> 2 orelse
217 String.isPrefix "type_definition" (List.last (space_explode "." s)) orelse
218 String.isSuffix "_def" s orelse
219 String.isSuffix "_raw" s
222 fun is_forbidden_mutant t =
223 let val consts = Term.add_const_names t [] in
224 exists (String.isPrefix "Nitpick") consts orelse
225 exists (String.isSubstring "_sumC") consts (* internal function *)
228 fun is_executable_term thy t = can (TimeLimit.timeLimit (Time.fromMilliseconds 2000) (Quickcheck.test_term
229 (ProofContext.init thy) false (SOME "SML") 1 0)) (preprocess thy [] t)
230 fun is_executable_thm thy th = is_executable_term thy (prop_of th)
233 map_types (map_type_tvar (fn ((a, i), S) =>
234 TFree (if i = 0 then a else a ^ "_" ^ string_of_int i, S)))
236 fun thms_of all thy =
238 (fn th => (all orelse Context.theory_name (theory_of_thm th) = Context.theory_name thy)
239 (* andalso is_executable_thm thy th *))
240 (map snd (filter_out is_forbidden_theorem (Mutabelle.all_unconcealed_thms_of thy)))
242 val count = length oo filter o equal
244 fun take_random 0 _ = []
245 | take_random _ [] = []
247 let val j = random_range 0 (length xs - 1) in
248 Library.nth xs j :: take_random (n - 1) (nth_drop j xs)
251 fun cpu_time description f =
253 val start = start_timing ()
254 val result = Exn.capture f ()
255 val time = Time.toMilliseconds (#cpu (end_timing start))
256 in (Exn.release result, (description, time)) end
258 fun safe_invoke_mtd thy (mtd_name, invoke_mtd) t =
260 val _ = priority ("Invoking " ^ mtd_name)
261 val ((res, (timing, reports)), time) = cpu_time "total time"
262 (fn () => case try (invoke_mtd thy) t of
263 SOME (res, (timing, reports)) => (res, (timing, reports))
264 | NONE => (priority ("**** PROBLEMS WITH " ^ Syntax.string_of_term_global thy t);
265 (Error , ([], NONE))))
266 val _ = priority (" Done")
267 in (res, (time :: timing, reports)) end
269 (* theory -> term list -> mtd -> subentry *)
271 fun test_mutants_using_one_method thy mutants (mtd_name, invoke_mtd) =
273 val res = map (safe_invoke_mtd thy (mtd_name, invoke_mtd)) mutants
275 (mtd_name, count GenuineCex res, count PotentialCex res, count NoCex res,
276 count Donno res, count Timeout res, count Error res)
279 fun create_entry thy thm exec mutants mtds =
280 (Thm.get_name thm, exec, map (test_mutants_using_one_method thy mutants) mtds)
282 fun create_detailed_entry thy thm exec mutants mtds =
284 fun create_mutant_subentry mutant = (mutant,
285 map (fn (mtd_name, invoke_mtd) =>
286 (mtd_name, safe_invoke_mtd thy (mtd_name, invoke_mtd) mutant)) mtds)
288 (Thm.get_name thm, exec, prop_of thm, map create_mutant_subentry mutants)
291 (* (theory -> thm -> bool -> term list -> mtd list -> 'a) -> theory -> mtd list -> thm -> 'a *)
292 fun mutate_theorem create_entry thy mtds thm =
294 val pp = Syntax.pp_global thy
295 val exec = is_executable_thm thy thm
296 val _ = priority (if exec then "EXEC" else "NOEXEC")
298 (if num_mutations = 0 then
301 Mutabelle.mutate_mix (Thm.prop_of thm) thy comms forbidden
303 |> filter_out is_forbidden_mutant
307 val _ = priority ("BEFORE PARTITION OF " ^
308 Int.toString (length mutants) ^ " MUTANTS")
309 val (execs, noexecs) = List.partition (is_executable_term thy) (take_random (20 * max_mutants) mutants)
310 val _ = tracing ("AFTER PARTITION (" ^ Int.toString (length execs) ^
311 " vs " ^ Int.toString (length noexecs) ^ ")")
313 execs @ take_random (Int.max (0, max_mutants - length execs)) noexecs
317 val mutants = mutants
318 |> take_random max_mutants
319 |> map Mutabelle.freeze |> map freezeT
320 (* |> filter (not o is_forbidden_mutant) *)
321 |> List.mapPartial (try (Sign.cert_term thy))
322 val _ = map (fn t => priority ("MUTANT: " ^ Pretty.string_of (Pretty.term pp t))) mutants
324 create_entry thy thm exec mutants mtds
327 (* theory -> mtd list -> thm list -> report *)
328 val mutate_theorems = map ooo mutate_theorem
330 fun string_of_outcome GenuineCex = "GenuineCex"
331 | string_of_outcome PotentialCex = "PotentialCex"
332 | string_of_outcome NoCex = "NoCex"
333 | string_of_outcome Donno = "Donno"
334 | string_of_outcome Timeout = "Timeout"
335 | string_of_outcome Error = "Error"
337 fun string_of_mutant_subentry thy thm_name (t, results) =
338 "mutant: " ^ Syntax.string_of_term_global thy t ^ "\n" ^
340 (map (fn (mtd_name, (outcome, timing)) => mtd_name ^ ": " ^ string_of_outcome outcome) results) ^
343 fun string_of_mutant_subentry' thy thm_name (t, results) =
345 fun string_of_report (Quickcheck.Report {iterations = i, raised_match_errors = e,
346 satisfied_assms = s, positive_concl_tests = p}) =
347 "errors: " ^ string_of_int e ^ "; conclusion tests: " ^ string_of_int p
348 fun string_of_reports NONE = ""
349 | string_of_reports (SOME reports) =
350 cat_lines (map (fn (size, [report]) =>
351 "size " ^ string_of_int size ^ ": " ^ string_of_report report) (rev reports))
352 fun string_of_mtd_result (mtd_name, (outcome, (timing, reports))) =
353 mtd_name ^ ": " ^ string_of_outcome outcome ^ "; " ^
354 space_implode "; " (map (fn (s, t) => (s ^ ": " ^ string_of_int t)) timing)
355 ^ "\n" ^ string_of_reports reports
357 "mutant of " ^ thm_name ^ ":\n" ^ cat_lines (map string_of_mtd_result results)
360 fun string_of_detailed_entry thy (thm_name, exec, t, mutant_subentries) =
361 thm_name ^ " " ^ (if exec then "[exe]" else "[noexe]") ^ ": " ^
362 Syntax.string_of_term_global thy t ^ "\n" ^
363 cat_lines (map (string_of_mutant_subentry' thy thm_name) mutant_subentries) ^ "\n"
365 (* subentry -> string *)
366 fun string_for_subentry (mtd_name, genuine_cex, potential_cex, no_cex, donno,
368 " " ^ mtd_name ^ ": " ^ Int.toString genuine_cex ^ "+ " ^
369 Int.toString potential_cex ^ "= " ^ Int.toString no_cex ^ "- " ^
370 Int.toString donno ^ "? " ^ Int.toString timeout ^ "T " ^
371 Int.toString error ^ "!"
372 (* entry -> string *)
373 fun string_for_entry (thm_name, exec, subentries) =
374 thm_name ^ " " ^ (if exec then "[exe]" else "[noexe]") ^ ":\n" ^
375 cat_lines (map string_for_subentry subentries) ^ "\n"
376 (* report -> string *)
377 fun string_for_report report = cat_lines (map string_for_entry report)
379 (* string -> report -> unit *)
380 fun write_report file_name =
381 File.write (Path.explode file_name) o string_for_report
383 (* theory -> mtd list -> thm list -> string -> unit *)
384 fun mutate_theorems_and_write_report thy mtds thms file_name =
386 val _ = priority "Starting Mutabelle..."
387 val path = Path.explode file_name
388 (* for normal report: *)
389 (*val (gen_create_entry, gen_string_for_entry) = (create_entry, string_for_entry)*)
390 (*for detailled report: *)
391 val (gen_create_entry, gen_string_for_entry) =
392 (create_detailed_entry, string_of_detailed_entry thy)
395 "Mutation options = " ^
396 "max_mutants: " ^ string_of_int max_mutants ^
397 "; num_mutations: " ^ string_of_int num_mutations ^ "\n" ^
399 (*"quickcheck_generator: " ^ quickcheck_generator ^ ";*)
400 "size: " ^ string_of_int size ^
401 "; iterations: " ^ string_of_int iterations ^ "\n");
402 map (File.append path o gen_string_for_entry o mutate_theorem gen_create_entry thy mtds) thms;