src/HOL/Mutabelle/mutabelle_extra.ML
author haftmann
Sat Aug 28 16:14:32 2010 +0200 (2010-08-28)
changeset 38864 4abe644fcea5
parent 38857 97775f3e8722
child 39133 70d3915c92f0
permissions -rw-r--r--
formerly unnamed infix equality now named HOL.eq
haftmann@37744
     1
(*  Title:      HOL/Mutabelle/mutabelle_extra.ML
bulwahn@34965
     2
    Author:     Stefan Berghofer, Jasmin Blanchette, Lukas Bulwahn, TU Muenchen
bulwahn@34965
     3
bulwahn@34965
     4
    Invokation of Counterexample generators
bulwahn@34965
     5
*)
bulwahn@34965
     6
signature MUTABELLE_EXTRA =
bulwahn@34965
     7
sig
bulwahn@34965
     8
bulwahn@34965
     9
val take_random : int -> 'a list -> 'a list
bulwahn@34965
    10
bulwahn@34965
    11
datatype outcome = GenuineCex | PotentialCex | NoCex | Donno | Timeout | Error
bulwahn@35324
    12
type timing = (string * int) list
bulwahn@34965
    13
bulwahn@35380
    14
type mtd = string * (theory -> term -> outcome * (timing * (int * Quickcheck.report list) list option))
bulwahn@35324
    15
bulwahn@35380
    16
type mutant_subentry = term * (string * (outcome * (timing * Quickcheck.report option))) list
bulwahn@34965
    17
type detailed_entry = string * bool * term * mutant_subentry list
bulwahn@34965
    18
bulwahn@34965
    19
type subentry = string * int * int * int * int * int * int
bulwahn@34965
    20
type entry = string * bool * subentry list
bulwahn@34965
    21
type report = entry list
bulwahn@34965
    22
bulwahn@34965
    23
val quickcheck_mtd : string -> mtd
bulwahn@34965
    24
(*
bulwahn@34965
    25
val refute_mtd : mtd
bulwahn@34965
    26
val nitpick_mtd : mtd
bulwahn@34965
    27
*)
bulwahn@34965
    28
bulwahn@34965
    29
val freezeT : term -> term
bulwahn@34965
    30
val thms_of : bool -> theory -> thm list
bulwahn@34965
    31
bulwahn@34965
    32
val string_for_report : report -> string
bulwahn@34965
    33
val write_report : string -> report -> unit
bulwahn@34965
    34
val mutate_theorems_and_write_report :
bulwahn@34965
    35
  theory -> mtd list -> thm list -> string -> unit
bulwahn@34965
    36
bulwahn@34965
    37
val random_seed : real Unsynchronized.ref
bulwahn@34965
    38
end;
bulwahn@34965
    39
bulwahn@34965
    40
structure MutabelleExtra : MUTABELLE_EXTRA =
bulwahn@34965
    41
struct
bulwahn@34965
    42
bulwahn@34965
    43
(* Own seed; can't rely on the Isabelle one to stay the same *)
bulwahn@34965
    44
val random_seed = Unsynchronized.ref 1.0;
bulwahn@34965
    45
bulwahn@34965
    46
bulwahn@34965
    47
(* mutation options *)
bulwahn@34965
    48
val max_mutants = 4
bulwahn@34965
    49
val num_mutations = 1
bulwahn@34965
    50
(* soundness check: *)
bulwahn@36255
    51
(*val max_mutants = 1
bulwahn@36255
    52
val num_mutations = 0*)
bulwahn@34965
    53
bulwahn@34965
    54
(* quickcheck options *)
bulwahn@34965
    55
(*val quickcheck_generator = "SML"*)
bulwahn@35537
    56
val iterations = 10
bulwahn@34965
    57
val size = 5
bulwahn@34965
    58
bulwahn@34965
    59
exception RANDOM;
bulwahn@34965
    60
bulwahn@34965
    61
fun rmod x y = x - y * Real.realFloor (x / y);
bulwahn@34965
    62
bulwahn@34965
    63
local
bulwahn@34965
    64
  val a = 16807.0;
bulwahn@34965
    65
  val m = 2147483647.0;
bulwahn@34965
    66
in
bulwahn@34965
    67
bulwahn@34965
    68
fun random () = CRITICAL (fn () =>
bulwahn@34965
    69
  let val r = rmod (a * ! random_seed) m
bulwahn@34965
    70
  in (random_seed := r; r) end);
bulwahn@34965
    71
bulwahn@34965
    72
end;
bulwahn@34965
    73
bulwahn@34965
    74
fun random_range l h =
bulwahn@34965
    75
  if h < l orelse l < 0 then raise RANDOM
bulwahn@34965
    76
  else l + Real.floor (rmod (random ()) (real (h - l + 1)));
bulwahn@34965
    77
bulwahn@34965
    78
datatype outcome = GenuineCex | PotentialCex | NoCex | Donno | Timeout | Error
bulwahn@35324
    79
type timing = (string * int) list
bulwahn@34965
    80
bulwahn@35380
    81
type mtd = string * (theory -> term -> outcome * (timing * (int * Quickcheck.report list) list option))
bulwahn@35324
    82
bulwahn@35380
    83
type mutant_subentry = term * (string * (outcome * (timing * Quickcheck.report option))) list
bulwahn@34965
    84
type detailed_entry = string * bool * term * mutant_subentry list
bulwahn@34965
    85
bulwahn@34965
    86
type subentry = string * int * int * int * int * int * int
bulwahn@34965
    87
type entry = string * bool * subentry list
bulwahn@34965
    88
type report = entry list
bulwahn@34965
    89
bulwahn@34965
    90
fun inst_type insts (Type (s, Ts)) = Type (s, map (inst_type insts) Ts)
bulwahn@34965
    91
  | inst_type insts T = the_default HOLogic.intT (AList.lookup op = insts T)
bulwahn@34965
    92
wenzelm@35625
    93
fun preprocess thy insts t = Object_Logic.atomize_term thy
bulwahn@34965
    94
 (map_types (inst_type insts) (Mutabelle.freeze t));
bulwahn@34965
    95
bulwahn@34965
    96
fun invoke_quickcheck quickcheck_generator thy t =
bulwahn@34965
    97
  TimeLimit.timeLimit (Time.fromSeconds (! Auto_Counterexample.time_limit))
bulwahn@34965
    98
      (fn _ =>
wenzelm@36610
    99
          case Quickcheck.gen_test_term (ProofContext.init_global thy) true true (SOME quickcheck_generator)
bulwahn@34965
   100
                                    size iterations (preprocess thy [] t) of
bulwahn@35380
   101
            (NONE, (time_report, report)) => (NoCex, (time_report, report))
bulwahn@35380
   102
          | (SOME _, (time_report, report)) => (GenuineCex, (time_report, report))) ()
bulwahn@35380
   103
  handle TimeLimit.TimeOut => (Timeout, ([("timelimit", !Auto_Counterexample.time_limit)], NONE))
bulwahn@34965
   104
bulwahn@34965
   105
fun quickcheck_mtd quickcheck_generator =
bulwahn@34965
   106
  ("quickcheck_" ^ quickcheck_generator, invoke_quickcheck quickcheck_generator)
bulwahn@34965
   107
bulwahn@34965
   108
  (*
bulwahn@34965
   109
fun invoke_refute thy t =
bulwahn@34965
   110
  let
bulwahn@34965
   111
    val res = MyRefute.refute_term thy [] t
bulwahn@34965
   112
    val _ = priority ("Refute: " ^ res)
bulwahn@34965
   113
  in
bulwahn@34965
   114
    case res of
bulwahn@34965
   115
      "genuine" => GenuineCex
bulwahn@34965
   116
    | "likely_genuine" => GenuineCex
bulwahn@34965
   117
    | "potential" => PotentialCex
bulwahn@34965
   118
    | "none" => NoCex
bulwahn@34965
   119
    | "unknown" => Donno
bulwahn@34965
   120
    | _ => Error
bulwahn@34965
   121
  end
bulwahn@34965
   122
  handle MyRefute.REFUTE (loc, details) =>
bulwahn@34965
   123
         (error ("Unhandled Refute error (" ^ quote loc ^ "): " ^ details ^
bulwahn@34965
   124
                   "."))
bulwahn@34965
   125
val refute_mtd = ("refute", invoke_refute)
bulwahn@34965
   126
*)
bulwahn@34965
   127
bulwahn@34965
   128
(*
bulwahn@34965
   129
open Nitpick_Util
bulwahn@34965
   130
open Nitpick_Rep
bulwahn@34965
   131
open Nitpick_Nut
bulwahn@34965
   132
bulwahn@34965
   133
fun invoke_nitpick thy t =
bulwahn@34965
   134
  let
wenzelm@36610
   135
    val ctxt = ProofContext.init_global thy
bulwahn@34965
   136
    val state = Proof.init ctxt
bulwahn@34965
   137
  in
bulwahn@34965
   138
    let
bulwahn@34965
   139
      val (res, _) = Nitpick.pick_nits_in_term state (Nitpick_Isar.default_params thy []) false [] t
bulwahn@34965
   140
      val _ = priority ("Nitpick: " ^ res)
bulwahn@34965
   141
    in
bulwahn@34965
   142
      case res of
bulwahn@34965
   143
        "genuine" => GenuineCex
bulwahn@34965
   144
      | "likely_genuine" => GenuineCex
bulwahn@34965
   145
      | "potential" => PotentialCex
bulwahn@34965
   146
      | "none" => NoCex
bulwahn@34965
   147
      | "unknown" => Donno
bulwahn@34965
   148
      | _ => Error
bulwahn@34965
   149
    end
bulwahn@34965
   150
    handle ARG (loc, details) =>
bulwahn@34965
   151
           (error ("Bad argument(s) to " ^ quote loc ^ ": " ^ details ^ "."))
bulwahn@34965
   152
         | BAD (loc, details) =>
bulwahn@34965
   153
           (error ("Internal error (" ^ quote loc ^ "): " ^ details ^ "."))
bulwahn@34965
   154
         | LIMIT (_, details) =>
bulwahn@34965
   155
           (warning ("Limit reached: " ^ details ^ "."); Donno)
bulwahn@34965
   156
         | NOT_SUPPORTED details =>
bulwahn@34965
   157
           (warning ("Unsupported case: " ^ details ^ "."); Donno)
bulwahn@34965
   158
         | NUT (loc, us) =>
bulwahn@34965
   159
           (error ("Invalid nut" ^ plural_s_for_list us ^
bulwahn@34965
   160
                   " (" ^ quote loc ^ "): " ^
bulwahn@34965
   161
                  commas (map (string_for_nut ctxt) us) ^ "."))
bulwahn@34965
   162
         | REP (loc, Rs) =>
bulwahn@34965
   163
           (error ("Invalid representation" ^ plural_s_for_list Rs ^
bulwahn@34965
   164
                   " (" ^ quote loc ^ "): " ^
bulwahn@34965
   165
                   commas (map string_for_rep Rs) ^ "."))
bulwahn@34965
   166
         | TERM (loc, ts) =>
bulwahn@34965
   167
           (error ("Invalid term" ^ plural_s_for_list ts ^
bulwahn@34965
   168
                   " (" ^ quote loc ^ "): " ^
bulwahn@34965
   169
                   commas (map (Syntax.string_of_term ctxt) ts) ^ "."))
bulwahn@34965
   170
         | TYPE (loc, Ts, ts) =>
bulwahn@34965
   171
           (error ("Invalid type" ^ plural_s_for_list Ts ^
bulwahn@34965
   172
                   (if null ts then
bulwahn@34965
   173
                      ""
bulwahn@34965
   174
                    else
bulwahn@34965
   175
                      " for term" ^ plural_s_for_list ts ^ " " ^
bulwahn@34965
   176
                      commas (map (quote o Syntax.string_of_term ctxt) ts)) ^
bulwahn@34965
   177
                   " (" ^ quote loc ^ "): " ^
bulwahn@34965
   178
                   commas (map (Syntax.string_of_typ ctxt) Ts) ^ "."))
bulwahn@34965
   179
         | Kodkod.SYNTAX (_, details) =>
bulwahn@34965
   180
           (warning ("Ill-formed Kodkodi output: " ^ details ^ "."); Error)
bulwahn@34965
   181
         | Refute.REFUTE (loc, details) =>
bulwahn@34965
   182
           (error ("Unhandled Refute error (" ^ quote loc ^ "): " ^ details ^
bulwahn@34965
   183
                   "."))
bulwahn@34965
   184
         | Exn.Interrupt => raise Exn.Interrupt
bulwahn@34965
   185
         | _ => (priority ("Unknown error in Nitpick"); Error)
bulwahn@34965
   186
  end
bulwahn@34965
   187
val nitpick_mtd = ("nitpick", invoke_nitpick)
bulwahn@34965
   188
*)
bulwahn@34965
   189
haftmann@38864
   190
val comms = [@{const_name HOL.eq}, @{const_name HOL.disj}, @{const_name HOL.conj}]
bulwahn@34965
   191
bulwahn@34965
   192
val forbidden =
bulwahn@34965
   193
 [(* (@{const_name "power"}, "'a"), *)
bulwahn@35325
   194
  (*(@{const_name induct_equal}, "'a"),
bulwahn@35325
   195
  (@{const_name induct_implies}, "'a"),
bulwahn@35325
   196
  (@{const_name induct_conj}, "'a"),*)
bulwahn@34965
   197
  (@{const_name "undefined"}, "'a"),
bulwahn@34965
   198
  (@{const_name "default"}, "'a"),
bulwahn@36255
   199
  (@{const_name "dummy_pattern"}, "'a::{}"),
bulwahn@36255
   200
  (@{const_name "HOL.simp_implies"}, "prop => prop => prop"),
bulwahn@36255
   201
  (@{const_name "bot_fun_inst.bot_fun"}, "'a"),
bulwahn@36255
   202
  (@{const_name "top_fun_inst.top_fun"}, "'a"),
bulwahn@36255
   203
  (@{const_name "Pure.term"}, "'a"),
bulwahn@36255
   204
  (@{const_name "top_class.top"}, "'a"),
haftmann@38857
   205
  (@{const_name "HOL.equal"}, "'a"),
bulwahn@36255
   206
  (@{const_name "Quotient.Quot_True"}, "'a")(*,
bulwahn@34965
   207
  (@{const_name "uminus"}, "'a"),
bulwahn@34965
   208
  (@{const_name "Nat.size"}, "'a"),
haftmann@35092
   209
  (@{const_name "Groups.abs"}, "'a") *)]
bulwahn@34965
   210
bulwahn@34965
   211
val forbidden_thms =
bulwahn@34965
   212
 ["finite_intvl_succ_class",
bulwahn@34965
   213
  "nibble"]
bulwahn@34965
   214
bulwahn@34965
   215
val forbidden_consts =
bulwahn@34965
   216
 [@{const_name nibble_pair_of_char}]
bulwahn@34965
   217
bulwahn@34965
   218
fun is_forbidden_theorem (s, th) =
bulwahn@34965
   219
  let val consts = Term.add_const_names (prop_of th) [] in
haftmann@36692
   220
    exists (member (op =) (space_explode "." s)) forbidden_thms orelse
haftmann@36692
   221
    exists (member (op =) forbidden_consts) consts orelse
bulwahn@34965
   222
    length (space_explode "." s) <> 2 orelse
bulwahn@34965
   223
    String.isPrefix "type_definition" (List.last (space_explode "." s)) orelse
bulwahn@34965
   224
    String.isSuffix "_def" s orelse
bulwahn@34965
   225
    String.isSuffix "_raw" s
bulwahn@34965
   226
  end
bulwahn@34965
   227
bulwahn@36255
   228
val forbidden_mutant_constnames =
bulwahn@36255
   229
 ["HOL.induct_equal",
bulwahn@36255
   230
  "HOL.induct_implies",
bulwahn@36255
   231
  "HOL.induct_conj",
bulwahn@36255
   232
 @{const_name undefined},
bulwahn@36255
   233
 @{const_name default},
bulwahn@36255
   234
 @{const_name dummy_pattern},
bulwahn@36255
   235
 @{const_name "HOL.simp_implies"},
bulwahn@36255
   236
 @{const_name "bot_fun_inst.bot_fun"},
bulwahn@36255
   237
 @{const_name "top_fun_inst.top_fun"},
bulwahn@36255
   238
 @{const_name "Pure.term"},
bulwahn@36255
   239
 @{const_name "top_class.top"},
haftmann@38857
   240
 @{const_name "HOL.equal"},
bulwahn@36255
   241
 @{const_name "Quotient.Quot_True"}]
bulwahn@36255
   242
bulwahn@34965
   243
fun is_forbidden_mutant t =
bulwahn@36255
   244
  let
bulwahn@36255
   245
    val consts = Term.add_const_names t []
bulwahn@36255
   246
  in
bulwahn@34965
   247
    exists (String.isPrefix "Nitpick") consts orelse
bulwahn@36255
   248
    exists (String.isSubstring "_sumC") consts orelse
bulwahn@36255
   249
    exists (member (op =) forbidden_mutant_constnames) consts
bulwahn@34965
   250
  end
bulwahn@34965
   251
bulwahn@34965
   252
fun is_executable_term thy t = can (TimeLimit.timeLimit (Time.fromMilliseconds 2000) (Quickcheck.test_term
wenzelm@36610
   253
 (ProofContext.init_global thy) false (SOME "SML") 1 0)) (preprocess thy [] t)
bulwahn@34965
   254
fun is_executable_thm thy th = is_executable_term thy (prop_of th)
bulwahn@34965
   255
bulwahn@34965
   256
val freezeT =
bulwahn@34965
   257
  map_types (map_type_tvar (fn ((a, i), S) =>
bulwahn@34965
   258
    TFree (if i = 0 then a else a ^ "_" ^ string_of_int i, S)))
bulwahn@34965
   259
bulwahn@34965
   260
fun thms_of all thy =
bulwahn@34965
   261
  filter
bulwahn@34965
   262
    (fn th => (all orelse Context.theory_name (theory_of_thm th) = Context.theory_name thy)
bulwahn@34965
   263
      (* andalso is_executable_thm thy th *))
bulwahn@34965
   264
    (map snd (filter_out is_forbidden_theorem (Mutabelle.all_unconcealed_thms_of thy)))
bulwahn@34965
   265
bulwahn@34965
   266
val count = length oo filter o equal
bulwahn@34965
   267
bulwahn@34965
   268
fun take_random 0 _ = []
bulwahn@34965
   269
  | take_random _ [] = []
bulwahn@34965
   270
  | take_random n xs =
bulwahn@34965
   271
    let val j = random_range 0 (length xs - 1) in
bulwahn@34965
   272
      Library.nth xs j :: take_random (n - 1) (nth_drop j xs)
bulwahn@34965
   273
    end
bulwahn@34965
   274
bulwahn@35324
   275
fun cpu_time description f =
bulwahn@35324
   276
  let
bulwahn@35324
   277
    val start = start_timing ()
bulwahn@35324
   278
    val result = Exn.capture f ()
bulwahn@35324
   279
    val time = Time.toMilliseconds (#cpu (end_timing start))
bulwahn@35324
   280
  in (Exn.release result, (description, time)) end
bulwahn@35324
   281
bulwahn@34965
   282
fun safe_invoke_mtd thy (mtd_name, invoke_mtd) t =
bulwahn@34965
   283
  let
bulwahn@34965
   284
    val _ = priority ("Invoking " ^ mtd_name)
bulwahn@35380
   285
    val ((res, (timing, reports)), time) = cpu_time "total time"
bulwahn@35324
   286
      (fn () => case try (invoke_mtd thy) t of
bulwahn@35380
   287
          SOME (res, (timing, reports)) => (res, (timing, reports))
bulwahn@35324
   288
        | NONE => (priority ("**** PROBLEMS WITH " ^ Syntax.string_of_term_global thy t);
bulwahn@35380
   289
           (Error , ([], NONE))))
bulwahn@34965
   290
    val _ = priority (" Done")
bulwahn@35380
   291
  in (res, (time :: timing, reports)) end
bulwahn@34965
   292
bulwahn@34965
   293
(* theory -> term list -> mtd -> subentry *)
bulwahn@35324
   294
(*
bulwahn@34965
   295
fun test_mutants_using_one_method thy mutants (mtd_name, invoke_mtd) =
bulwahn@34965
   296
  let
bulwahn@34965
   297
     val res = map (safe_invoke_mtd thy (mtd_name, invoke_mtd)) mutants
bulwahn@34965
   298
  in
bulwahn@34965
   299
    (mtd_name, count GenuineCex res, count PotentialCex res, count NoCex res,
bulwahn@34965
   300
     count Donno res, count Timeout res, count Error res)
bulwahn@34965
   301
  end
bulwahn@34965
   302
bulwahn@34965
   303
fun create_entry thy thm exec mutants mtds =
wenzelm@36743
   304
  (Thm.get_name_hint thm, exec, map (test_mutants_using_one_method thy mutants) mtds)
bulwahn@35324
   305
*)
bulwahn@34965
   306
fun create_detailed_entry thy thm exec mutants mtds =
bulwahn@34965
   307
  let
bulwahn@34965
   308
    fun create_mutant_subentry mutant = (mutant,
bulwahn@34965
   309
      map (fn (mtd_name, invoke_mtd) =>
bulwahn@34965
   310
        (mtd_name, safe_invoke_mtd thy (mtd_name, invoke_mtd) mutant)) mtds)
bulwahn@34965
   311
  in
wenzelm@36743
   312
    (Thm.get_name_hint thm, exec, prop_of thm, map create_mutant_subentry mutants)
bulwahn@34965
   313
  end
bulwahn@34965
   314
bulwahn@34965
   315
(* (theory -> thm -> bool -> term list -> mtd list -> 'a) -> theory -> mtd list -> thm -> 'a *)
bulwahn@34965
   316
fun mutate_theorem create_entry thy mtds thm =
bulwahn@34965
   317
  let
bulwahn@34965
   318
    val pp = Syntax.pp_global thy
bulwahn@34965
   319
    val exec = is_executable_thm thy thm
bulwahn@34965
   320
    val _ = priority (if exec then "EXEC" else "NOEXEC")
bulwahn@34965
   321
    val mutants =
bulwahn@34965
   322
          (if num_mutations = 0 then
bulwahn@34965
   323
             [Thm.prop_of thm]
bulwahn@34965
   324
           else
bulwahn@34965
   325
             Mutabelle.mutate_mix (Thm.prop_of thm) thy comms forbidden
bulwahn@34965
   326
                                  num_mutations)
bulwahn@34965
   327
             |> filter_out is_forbidden_mutant
bulwahn@34965
   328
    val mutants =
bulwahn@34965
   329
      if exec then
bulwahn@34965
   330
        let
bulwahn@34965
   331
          val _ = priority ("BEFORE PARTITION OF " ^
bulwahn@34965
   332
                            Int.toString (length mutants) ^ " MUTANTS")
bulwahn@34965
   333
          val (execs, noexecs) = List.partition (is_executable_term thy) (take_random (20 * max_mutants) mutants)
bulwahn@34965
   334
          val _ = tracing ("AFTER PARTITION (" ^ Int.toString (length execs) ^
bulwahn@34965
   335
                           " vs " ^ Int.toString (length noexecs) ^ ")")
bulwahn@34965
   336
        in
bulwahn@34965
   337
          execs @ take_random (Int.max (0, max_mutants - length execs)) noexecs
bulwahn@34965
   338
        end
bulwahn@34965
   339
      else
bulwahn@34965
   340
        mutants
bulwahn@34965
   341
    val mutants = mutants
bulwahn@34965
   342
          |> take_random max_mutants
bulwahn@34965
   343
          |> map Mutabelle.freeze |> map freezeT
bulwahn@34965
   344
(*          |> filter (not o is_forbidden_mutant) *)
bulwahn@34965
   345
          |> List.mapPartial (try (Sign.cert_term thy))
bulwahn@34965
   346
    val _ = map (fn t => priority ("MUTANT: " ^ Pretty.string_of (Pretty.term pp t))) mutants
bulwahn@34965
   347
  in
bulwahn@34965
   348
    create_entry thy thm exec mutants mtds
bulwahn@34965
   349
  end
bulwahn@34965
   350
bulwahn@34965
   351
(* theory -> mtd list -> thm list -> report *)
bulwahn@34965
   352
val mutate_theorems = map ooo mutate_theorem
bulwahn@34965
   353
bulwahn@34965
   354
fun string_of_outcome GenuineCex = "GenuineCex"
bulwahn@34965
   355
  | string_of_outcome PotentialCex = "PotentialCex"
bulwahn@34965
   356
  | string_of_outcome NoCex = "NoCex"
bulwahn@34965
   357
  | string_of_outcome Donno = "Donno"
bulwahn@34965
   358
  | string_of_outcome Timeout = "Timeout"
bulwahn@34965
   359
  | string_of_outcome Error = "Error"
bulwahn@34965
   360
bulwahn@35324
   361
fun string_of_mutant_subentry thy thm_name (t, results) =
bulwahn@34965
   362
  "mutant: " ^ Syntax.string_of_term_global thy t ^ "\n" ^
bulwahn@35324
   363
  space_implode "; "
bulwahn@35324
   364
    (map (fn (mtd_name, (outcome, timing)) => mtd_name ^ ": " ^ string_of_outcome outcome) results) ^
bulwahn@34965
   365
  "\n"
bulwahn@34965
   366
bulwahn@36255
   367
(* XML.tree -> string *)
bulwahn@36255
   368
fun plain_string_from_xml_tree t =
bulwahn@36255
   369
  Buffer.empty |> XML.add_content t |> Buffer.content
bulwahn@36255
   370
(* string -> string *)
bulwahn@36255
   371
val unyxml = plain_string_from_xml_tree o YXML.parse
bulwahn@36255
   372
bulwahn@35324
   373
fun string_of_mutant_subentry' thy thm_name (t, results) =
bulwahn@35380
   374
  let
bulwahn@35380
   375
    fun string_of_report (Quickcheck.Report {iterations = i, raised_match_errors = e,
bulwahn@35380
   376
      satisfied_assms = s, positive_concl_tests = p}) =
bulwahn@35380
   377
      "errors: " ^ string_of_int e ^ "; conclusion tests: " ^ string_of_int p
bulwahn@35380
   378
    fun string_of_reports NONE = ""
bulwahn@35380
   379
      | string_of_reports (SOME reports) =
bulwahn@35380
   380
        cat_lines (map (fn (size, [report]) =>
bulwahn@35380
   381
          "size " ^ string_of_int size ^ ": " ^ string_of_report report) (rev reports))
bulwahn@35380
   382
    fun string_of_mtd_result (mtd_name, (outcome, (timing, reports))) =
bulwahn@35324
   383
      mtd_name ^ ": " ^ string_of_outcome outcome ^ "; " ^
bulwahn@35380
   384
      space_implode "; " (map (fn (s, t) => (s ^ ": " ^ string_of_int t)) timing)
bulwahn@36255
   385
      (*^ "\n" ^ string_of_reports reports*)
bulwahn@35380
   386
  in
bulwahn@36255
   387
    "mutant of " ^ thm_name ^ ":\n"
bulwahn@36255
   388
    ^ unyxml (Syntax.string_of_term_global thy t) ^ "\n" ^ cat_lines (map string_of_mtd_result results)
bulwahn@35380
   389
  end
bulwahn@35324
   390
bulwahn@34965
   391
fun string_of_detailed_entry thy (thm_name, exec, t, mutant_subentries) = 
bulwahn@34965
   392
   thm_name ^ " " ^ (if exec then "[exe]" else "[noexe]") ^ ": " ^
bulwahn@36255
   393
   Syntax.string_of_term_global thy t ^ "\n" ^                                    
bulwahn@35324
   394
   cat_lines (map (string_of_mutant_subentry' thy thm_name) mutant_subentries) ^ "\n"
bulwahn@34965
   395
bulwahn@36255
   396
fun theoryfile_string_of_mutant_subentry thy thm_name (i, (t, results)) =
bulwahn@36255
   397
  "lemma " ^ thm_name ^ "_" ^ string_of_int (i + 1) ^ ":\n" ^
bulwahn@36255
   398
  "\"" ^ unyxml (Syntax.string_of_term_global thy t) ^
bulwahn@36255
   399
  "\" \nquickcheck[generator = SML]\nquickcheck[generator = predicate_compile_wo_ff]\n" ^
bulwahn@36255
   400
  "quickcheck[generator = predicate_compile_ff_nofs]\noops\n"
bulwahn@36255
   401
bulwahn@36255
   402
fun theoryfile_string_of_detailed_entry thy (thm_name, exec, t, mutant_subentries) =
bulwahn@36255
   403
  "subsubsection {* mutants of " ^ thm_name ^ " *}\n\n" ^
bulwahn@36255
   404
  cat_lines (map_index
bulwahn@36255
   405
    (theoryfile_string_of_mutant_subentry thy thm_name) mutant_subentries) ^ "\n"
bulwahn@36255
   406
bulwahn@34965
   407
(* subentry -> string *)
bulwahn@34965
   408
fun string_for_subentry (mtd_name, genuine_cex, potential_cex, no_cex, donno,
bulwahn@34965
   409
                         timeout, error) =
bulwahn@34965
   410
  "    " ^ mtd_name ^ ": " ^ Int.toString genuine_cex ^ "+ " ^
bulwahn@34965
   411
  Int.toString potential_cex ^ "= " ^ Int.toString no_cex ^ "- " ^
bulwahn@34965
   412
  Int.toString donno ^ "? " ^ Int.toString timeout ^ "T " ^
bulwahn@34965
   413
  Int.toString error ^ "!"
bulwahn@34965
   414
(* entry -> string *)
bulwahn@34965
   415
fun string_for_entry (thm_name, exec, subentries) =
bulwahn@34965
   416
  thm_name ^ " " ^ (if exec then "[exe]" else "[noexe]") ^ ":\n" ^
bulwahn@34965
   417
  cat_lines (map string_for_subentry subentries) ^ "\n"
bulwahn@34965
   418
(* report -> string *)
bulwahn@34965
   419
fun string_for_report report = cat_lines (map string_for_entry report)
bulwahn@34965
   420
bulwahn@34965
   421
(* string -> report -> unit *)
bulwahn@34965
   422
fun write_report file_name =
bulwahn@34965
   423
  File.write (Path.explode file_name) o string_for_report
bulwahn@34965
   424
bulwahn@34965
   425
(* theory -> mtd list -> thm list -> string -> unit *)
bulwahn@34965
   426
fun mutate_theorems_and_write_report thy mtds thms file_name =
bulwahn@34965
   427
  let
bulwahn@34965
   428
    val _ = priority "Starting Mutabelle..."
bulwahn@34965
   429
    val path = Path.explode file_name
bulwahn@34965
   430
    (* for normal report: *)
bulwahn@34965
   431
    (*val (gen_create_entry, gen_string_for_entry) = (create_entry, string_for_entry)*)
bulwahn@34965
   432
    (*for detailled report: *)
bulwahn@34965
   433
    val (gen_create_entry, gen_string_for_entry) =
bulwahn@34965
   434
      (create_detailed_entry, string_of_detailed_entry thy)
bulwahn@36255
   435
    val (gen_create_entry, gen_string_for_entry) =
bulwahn@36255
   436
      (create_detailed_entry, theoryfile_string_of_detailed_entry thy)
bulwahn@34965
   437
  in
bulwahn@34965
   438
    File.write path (
bulwahn@34965
   439
    "Mutation options = "  ^
bulwahn@34965
   440
      "max_mutants: " ^ string_of_int max_mutants ^
bulwahn@34965
   441
      "; num_mutations: " ^ string_of_int num_mutations ^ "\n" ^
bulwahn@34965
   442
    "QC options = " ^
bulwahn@34965
   443
      (*"quickcheck_generator: " ^ quickcheck_generator ^ ";*)
bulwahn@34965
   444
      "size: " ^ string_of_int size ^
bulwahn@34965
   445
      "; iterations: " ^ string_of_int iterations ^ "\n");
bulwahn@34965
   446
    map (File.append path o gen_string_for_entry o mutate_theorem gen_create_entry thy mtds) thms;
bulwahn@34965
   447
    ()
bulwahn@34965
   448
  end
bulwahn@34965
   449
bulwahn@34965
   450
end;