src/Tools/quickcheck.ML
author bulwahn
Fri, 01 Apr 2011 09:20:59 +0200
changeset 43059 f6bc441fbf19
parent 43033 00899500c6ca
child 43065 bd416284a432
permissions -rw-r--r--
adding time profiling in quickcheck's batch testing for further diagnosis in IsaCoSy
wenzelm@30826
     1
(*  Title:      Tools/quickcheck.ML
bulwahn@40481
     2
    Author:     Stefan Berghofer, Florian Haftmann, Lukas Bulwahn, TU Muenchen
haftmann@28256
     3
haftmann@28256
     4
Generic counterexample search engine.
haftmann@28256
     5
*)
haftmann@28256
     6
haftmann@28256
     7
signature QUICKCHECK =
haftmann@28256
     8
sig
bulwahn@38150
     9
  val setup: theory -> theory
bulwahn@38150
    10
  (* configuration *)
wenzelm@32740
    11
  val auto: bool Unsynchronized.ref
wenzelm@41765
    12
  val tester : string Config.T
bulwahn@40892
    13
  val size : int Config.T
bulwahn@40892
    14
  val iterations : int Config.T
bulwahn@40892
    15
  val no_assms : bool Config.T
bulwahn@40892
    16
  val report : bool Config.T
bulwahn@42952
    17
  val timing : bool Config.T
bulwahn@40892
    18
  val quiet : bool Config.T
bulwahn@40892
    19
  val timeout : real Config.T
bulwahn@40896
    20
  val finite_types : bool Config.T
bulwahn@40896
    21
  val finite_type_size : int Config.T
wenzelm@41765
    22
  datatype expectation = No_Expectation | No_Counterexample | Counterexample;
bulwahn@40892
    23
  datatype test_params = Test_Params of {default_type: typ list, expect : expectation};
bulwahn@40481
    24
  val test_params_of : Proof.context -> test_params
bulwahn@40892
    25
  val map_test_params : (typ list * expectation -> typ list * expectation)
bulwahn@40481
    26
    -> Context.generic -> Context.generic
bulwahn@42953
    27
  datatype report = Report of
bulwahn@42953
    28
    { iterations : int, raised_match_errors : int,
bulwahn@42953
    29
      satisfied_assms : int list, positive_concl_tests : int }
bulwahn@42953
    30
  (* registering generators *)
bulwahn@38150
    31
  val add_generator:
bulwahn@43030
    32
    string * (Proof.context -> (term * term list) list -> int list -> term list option * report option)
bulwahn@39479
    33
      -> Context.generic -> Context.generic
bulwahn@42733
    34
  val add_batch_generator:
bulwahn@42733
    35
    string * (Proof.context -> term list -> (int -> term list option) list)
bulwahn@42733
    36
      -> Context.generic -> Context.generic
bulwahn@42953
    37
  (* quickcheck's result *)
bulwahn@42952
    38
  datatype result =
bulwahn@42952
    39
    Result of
bulwahn@42952
    40
     {counterexample : (string * term) list option,
bulwahn@42952
    41
      evaluation_terms : (term * term) list option,
bulwahn@42952
    42
      timings : (string * int) list,
bulwahn@42952
    43
      reports : (int * report) list}
bulwahn@42953
    44
  val counterexample_of : result -> (string * term) list option
bulwahn@42953
    45
  val timings_of : result -> (string * int) list
bulwahn@38150
    46
  (* testing terms and proof states *)
bulwahn@42952
    47
  val test_term: Proof.context -> bool * bool -> term * term list -> result
bulwahn@40896
    48
  val test_goal_terms:
bulwahn@42897
    49
    Proof.context -> bool * bool -> (string * typ) list -> (term * term list) list  
bulwahn@42952
    50
      -> result list
bulwahn@38149
    51
  val quickcheck: (string * string list) list -> int -> Proof.state -> (string * term) list option
bulwahn@42733
    52
  (* testing a batch of terms *)
bulwahn@43059
    53
  val test_terms:
bulwahn@43059
    54
    Proof.context -> term list -> (string * term) list option list option * (string * int) list
haftmann@28256
    55
end;
haftmann@28256
    56
haftmann@28256
    57
structure Quickcheck : QUICKCHECK =
haftmann@28256
    58
struct
haftmann@28256
    59
wenzelm@30981
    60
(* preferences *)
wenzelm@30981
    61
wenzelm@32740
    62
val auto = Unsynchronized.ref false;
wenzelm@30981
    63
wenzelm@30981
    64
val _ =
wenzelm@30981
    65
  ProofGeneralPgip.add_preference Preferences.category_tracing
wenzelm@39862
    66
  (Unsynchronized.setmp auto true (fn () =>
wenzelm@30981
    67
    Preferences.bool_pref auto
wenzelm@30981
    68
      "auto-quickcheck"
blanchet@39575
    69
      "Run Quickcheck automatically.") ());
wenzelm@30981
    70
bulwahn@35378
    71
(* quickcheck report *)
bulwahn@35378
    72
bulwahn@35378
    73
datatype report = Report of
bulwahn@35378
    74
  { iterations : int, raised_match_errors : int,
bulwahn@35378
    75
    satisfied_assms : int list, positive_concl_tests : int }
bulwahn@35378
    76
bulwahn@42952
    77
(* Quickcheck Result *)
bulwahn@42952
    78
bulwahn@42952
    79
datatype result = Result of
bulwahn@42952
    80
  { counterexample : (string * term) list option, evaluation_terms : (term * term) list option,
bulwahn@42952
    81
    timings : (string * int) list, reports : (int * report) list}
bulwahn@42952
    82
bulwahn@42952
    83
val empty_result =
bulwahn@42952
    84
  Result {counterexample = NONE, evaluation_terms = NONE, timings = [], reports = []}
bulwahn@42952
    85
bulwahn@42952
    86
fun counterexample_of (Result r) = #counterexample r
bulwahn@42952
    87
bulwahn@42952
    88
fun found_counterexample (Result r) = is_some (#counterexample r)
bulwahn@42952
    89
bulwahn@42952
    90
fun response_of (Result r) = case (#counterexample r, #evaluation_terms r) of
bulwahn@42952
    91
    (SOME ts, SOME evals) => SOME (ts, evals)
bulwahn@42952
    92
  | (NONE, NONE) => NONE
bulwahn@42952
    93
bulwahn@42952
    94
fun timings_of (Result r) = #timings r
bulwahn@42952
    95
bulwahn@42952
    96
fun set_reponse names eval_terms (SOME ts) (Result r) =
bulwahn@42952
    97
  let
bulwahn@42952
    98
    val (ts1, ts2) = chop (length names) ts
bulwahn@42952
    99
  in
bulwahn@42952
   100
    Result {counterexample = SOME (names ~~ ts1), evaluation_terms = SOME (eval_terms ~~ ts2),
bulwahn@42952
   101
      timings = #timings r, reports = #reports r}
bulwahn@42952
   102
  end
bulwahn@42952
   103
  | set_reponse _ _ NONE result = result
bulwahn@42952
   104
bulwahn@42952
   105
fun cons_timing timing (Result r) =
bulwahn@42952
   106
  Result {counterexample = #counterexample r, evaluation_terms = #evaluation_terms r,
bulwahn@42952
   107
    timings = cons timing (#timings r), reports = #reports r}
bulwahn@42952
   108
bulwahn@42952
   109
fun cons_report size (SOME report) (Result r) =
bulwahn@42952
   110
  Result {counterexample = #counterexample r, evaluation_terms = #evaluation_terms r,
bulwahn@42952
   111
    timings = #timings r, reports = cons (size, report) (#reports r)}
bulwahn@42952
   112
  | cons_report _ NONE result = result
bulwahn@42952
   113
bulwahn@42952
   114
fun add_timing timing result_ref = (result_ref := cons_timing timing (!result_ref))
bulwahn@42952
   115
bulwahn@42952
   116
fun add_report size report result_ref = (result_ref := cons_report size report (!result_ref))
bulwahn@42952
   117
bulwahn@42952
   118
fun add_response names eval_terms response result_ref =
bulwahn@42952
   119
  (result_ref := set_reponse names eval_terms response (!result_ref))
bulwahn@42952
   120
bulwahn@38169
   121
(* expectation *)
bulwahn@38169
   122
wenzelm@41765
   123
datatype expectation = No_Expectation | No_Counterexample | Counterexample;
bulwahn@38169
   124
bulwahn@38169
   125
fun merge_expectation (expect1, expect2) =
bulwahn@38169
   126
  if expect1 = expect2 then expect1 else No_Expectation
bulwahn@38169
   127
haftmann@28315
   128
(* quickcheck configuration -- default parameters, test generators *)
bulwahn@41152
   129
val (tester, setup_tester) = Attrib.config_string "quickcheck_tester" (K "")
bulwahn@40892
   130
val (size, setup_size) = Attrib.config_int "quickcheck_size" (K 10)
bulwahn@40892
   131
val (iterations, setup_iterations) = Attrib.config_int "quickcheck_iterations" (K 100)
bulwahn@40892
   132
val (no_assms, setup_no_assms) = Attrib.config_bool "quickcheck_no_assms" (K false)
bulwahn@40892
   133
val (report, setup_report) = Attrib.config_bool "quickcheck_report" (K true)
bulwahn@42952
   134
val (timing, setup_timing) = Attrib.config_bool "quickcheck_timing" (K false)
bulwahn@40892
   135
val (quiet, setup_quiet) = Attrib.config_bool "quickcheck_quiet" (K false)
bulwahn@40892
   136
val (timeout, setup_timeout) = Attrib.config_real "quickcheck_timeout" (K 30.0)
bulwahn@40894
   137
val (finite_types, setup_finite_types) = Attrib.config_bool "quickcheck_finite_types" (K true)
wenzelm@41765
   138
val (finite_type_size, setup_finite_type_size) =
wenzelm@41765
   139
  Attrib.config_int "quickcheck_finite_type_size" (K 3)
haftmann@28315
   140
bulwahn@40892
   141
val setup_config =
bulwahn@42952
   142
  setup_tester #> setup_size #> setup_iterations #> setup_no_assms #> setup_report #> setup_timing
bulwahn@42952
   143
    #> setup_quiet #> setup_timeout #> setup_finite_types #> setup_finite_type_size
bulwahn@40894
   144
haftmann@28309
   145
datatype test_params = Test_Params of
bulwahn@40892
   146
  {default_type: typ list, expect : expectation};
haftmann@28309
   147
bulwahn@40892
   148
fun dest_test_params (Test_Params {default_type, expect}) = (default_type, expect);
wenzelm@39034
   149
wenzelm@41765
   150
fun make_test_params (default_type, expect) =
wenzelm@41765
   151
  Test_Params {default_type = default_type, expect = expect};
wenzelm@39034
   152
wenzelm@41765
   153
fun map_test_params' f (Test_Params {default_type, expect}) =
wenzelm@41765
   154
  make_test_params (f (default_type, expect));
wenzelm@39034
   155
wenzelm@39034
   156
fun merge_test_params
wenzelm@41720
   157
  (Test_Params {default_type = default_type1, expect = expect1},
wenzelm@41720
   158
    Test_Params {default_type = default_type2, expect = expect2}) =
wenzelm@41720
   159
  make_test_params
wenzelm@41720
   160
    (merge (op =) (default_type1, default_type2), merge_expectation (expect1, expect2));
haftmann@28309
   161
bulwahn@39479
   162
structure Data = Generic_Data
wenzelm@33522
   163
(
wenzelm@39034
   164
  type T =
bulwahn@43030
   165
    ((string * (Proof.context -> (term * term list) list -> int list -> term list option * report option)) list
bulwahn@42733
   166
      * (string * (Proof.context -> term list -> (int -> term list option) list)) list)
wenzelm@39034
   167
      * test_params;
bulwahn@42733
   168
  val empty = (([], []), Test_Params {default_type = [], expect = No_Expectation});
haftmann@28256
   169
  val extend = I;
bulwahn@42733
   170
  fun merge (((generators1, batch_generators1), params1), ((generators2, batch_generators2), params2)) : T =
bulwahn@42733
   171
    ((AList.merge (op =) (K true) (generators1, generators2),
bulwahn@42733
   172
    AList.merge (op =) (K true) (batch_generators1, batch_generators2)),
haftmann@28309
   173
      merge_test_params (params1, params2));
wenzelm@33522
   174
);
haftmann@28256
   175
bulwahn@39479
   176
val test_params_of = snd o Data.get o Context.Proof;
bulwahn@38150
   177
bulwahn@40892
   178
val default_type = fst o dest_test_params o test_params_of
bulwahn@40481
   179
bulwahn@40892
   180
val expect = snd o dest_test_params o test_params_of
bulwahn@40481
   181
bulwahn@40481
   182
val map_test_params = Data.map o apsnd o map_test_params'
bulwahn@39480
   183
bulwahn@42733
   184
val add_generator = Data.map o apfst o apfst o AList.update (op =);
bulwahn@42733
   185
bulwahn@42733
   186
val add_batch_generator = Data.map o apfst o apsnd o AList.update (op =);
haftmann@28256
   187
haftmann@28315
   188
(* generating tests *)
haftmann@28315
   189
bulwahn@42733
   190
fun gen_mk_tester lookup ctxt v =
haftmann@28309
   191
  let
bulwahn@41153
   192
    val name = Config.get ctxt tester
bulwahn@42733
   193
    val tester = case lookup ctxt name
bulwahn@41153
   194
      of NONE => error ("No such quickcheck tester: " ^ name)
bulwahn@41153
   195
      | SOME tester => tester ctxt;
wenzelm@40491
   196
  in
bulwahn@41153
   197
    if Config.get ctxt quiet then
bulwahn@42733
   198
      try tester v
bulwahn@41153
   199
    else
bulwahn@41153
   200
      let
bulwahn@42733
   201
        val tester = Exn.interruptible_capture tester v
bulwahn@41153
   202
      in case Exn.get_result tester of
bulwahn@41153
   203
          NONE => SOME (Exn.release tester)
bulwahn@41153
   204
        | SOME tester => SOME tester
bulwahn@41153
   205
      end
bulwahn@41153
   206
  end
haftmann@28315
   207
bulwahn@42733
   208
val mk_tester = gen_mk_tester (fn ctxt =>
bulwahn@42733
   209
  AList.lookup (op =) ((fst o fst o Data.get o Context.Proof) ctxt))
bulwahn@42733
   210
val mk_batch_tester = gen_mk_tester (fn ctxt => AList.lookup (op =) ((snd o fst o Data.get o Context.Proof) ctxt))
bulwahn@42733
   211
  
haftmann@28315
   212
(* testing propositions *)
haftmann@28315
   213
bulwahn@42899
   214
fun check_test_term t =
haftmann@28309
   215
  let
wenzelm@29266
   216
    val _ = (null (Term.add_tvars t []) andalso null (Term.add_tfrees t [])) orelse
haftmann@28309
   217
      error "Term to be tested contains type variables";
wenzelm@29266
   218
    val _ = null (Term.add_vars t []) orelse
haftmann@28309
   219
      error "Term to be tested contains schematic variables";
bulwahn@42899
   220
  in () end
haftmann@28309
   221
wenzelm@42885
   222
fun cpu_time description e =
wenzelm@42885
   223
  let val ({cpu, ...}, result) = Timing.timing e ()
wenzelm@42885
   224
  in (result, (description, Time.toMilliseconds cpu)) end
wenzelm@41765
   225
bulwahn@42625
   226
fun limit ctxt (limit_time, is_interactive) f exc () =
bulwahn@42625
   227
  if limit_time then
bulwahn@42625
   228
      TimeLimit.timeLimit (seconds (Config.get ctxt timeout)) f ()
bulwahn@42625
   229
    handle TimeLimit.TimeOut =>
bulwahn@42625
   230
      if is_interactive then exc () else raise TimeLimit.TimeOut
bulwahn@42625
   231
  else
bulwahn@42625
   232
    f ()
bulwahn@42624
   233
bulwahn@42897
   234
fun test_term ctxt (limit_time, is_interactive) (t, eval_terms) =
bulwahn@42733
   235
  let
bulwahn@42952
   236
    fun message s = if Config.get ctxt quiet then () else Output.urgent_message s
bulwahn@42899
   237
    val _ = check_test_term t
bulwahn@42899
   238
    val names = Term.add_free_names t []
bulwahn@40612
   239
    val current_size = Unsynchronized.ref 0
bulwahn@42952
   240
    val current_result = Unsynchronized.ref empty_result 
bulwahn@42951
   241
    fun excipit () =
bulwahn@42951
   242
      "Quickcheck ran out of time while testing at size " ^ string_of_int (!current_size)
bulwahn@42952
   243
    fun with_size test_fun k =
bulwahn@41155
   244
      if k > Config.get ctxt size then
bulwahn@42952
   245
        NONE
bulwahn@41155
   246
      else
bulwahn@35378
   247
        let
bulwahn@42952
   248
          val _ = message ("Test data size: " ^ string_of_int k)
bulwahn@40896
   249
          val _ = current_size := k
bulwahn@42952
   250
          val ((result, report), timing) =
bulwahn@43030
   251
            cpu_time ("size " ^ string_of_int k) (fn () => test_fun [1, k - 1])
bulwahn@42952
   252
          val _ = add_timing timing current_result
bulwahn@42952
   253
          val _ = add_report k report current_result
wenzelm@41765
   254
        in
bulwahn@42952
   255
          case result of NONE => with_size test_fun (k + 1) | SOME q => SOME q
wenzelm@41765
   256
        end;
bulwahn@34935
   257
  in
bulwahn@43033
   258
    limit ctxt (limit_time, is_interactive) (fn () =>
bulwahn@43033
   259
      let
bulwahn@43033
   260
        val (test_fun, comp_time) = cpu_time "quickcheck compilation"
bulwahn@43033
   261
          (fn () => mk_tester ctxt [(t, eval_terms)]);
bulwahn@43033
   262
        val _ = add_timing comp_time current_result
bulwahn@43033
   263
      in
bulwahn@43033
   264
        case test_fun of NONE => !current_result
bulwahn@43033
   265
          | SOME test_fun =>
bulwahn@43033
   266
            let
bulwahn@43033
   267
              val (response, exec_time) =
bulwahn@43033
   268
                cpu_time "quickcheck execution" (fn () => with_size test_fun 1)
bulwahn@43033
   269
              val _ = add_response names eval_terms response current_result
bulwahn@43033
   270
              val _ = add_timing exec_time current_result
bulwahn@43033
   271
            in
bulwahn@43033
   272
              !current_result
bulwahn@43033
   273
            end
bulwahn@43033
   274
       end)
bulwahn@43033
   275
     (fn () => (message (excipit ()); !current_result)) ()
haftmann@28309
   276
  end;
haftmann@28309
   277
bulwahn@42733
   278
fun test_terms ctxt ts =
bulwahn@42733
   279
  let
bulwahn@42899
   280
    val _ = map check_test_term ts
bulwahn@42899
   281
    val namess = map (fn t => Term.add_free_names t []) ts
bulwahn@43059
   282
    val (test_funs, comp_time) = cpu_time "quickcheck batch compilation" (fn () => mk_batch_tester ctxt ts) 
bulwahn@42733
   283
    fun with_size tester k =
bulwahn@42733
   284
      if k > Config.get ctxt size then NONE
bulwahn@42733
   285
      else case tester k of SOME ts => SOME ts | NONE => with_size tester (k + 1)
bulwahn@43059
   286
    val (results, exec_time) = cpu_time "quickcheck batch execution" (fn () =>
bulwahn@43059
   287
        Option.map (map (fn test_fun => TimeLimit.timeLimit (seconds (Config.get ctxt timeout))
bulwahn@43059
   288
              (fn () => with_size test_fun 1)  ()
bulwahn@43059
   289
             handle TimeLimit.TimeOut => NONE)) test_funs)
bulwahn@42733
   290
  in
bulwahn@43059
   291
    (Option.map (map2 (fn names => Option.map (fn ts => names ~~ ts)) namess) results,
bulwahn@43059
   292
      [comp_time, exec_time])
bulwahn@42733
   293
  end
bulwahn@42733
   294
bulwahn@41334
   295
(* FIXME: this function shows that many assumptions are made upon the generation *)
bulwahn@41334
   296
(* In the end there is probably no generic quickcheck interface left... *)
bulwahn@41334
   297
bulwahn@42625
   298
fun test_term_with_increasing_cardinality ctxt (limit_time, is_interactive) ts =
bulwahn@41291
   299
  let
bulwahn@41334
   300
    val thy = ProofContext.theory_of ctxt
bulwahn@42952
   301
    fun message s = if Config.get ctxt quiet then () else Output.urgent_message s
bulwahn@43030
   302
    val (ts', eval_terms) = split_list ts
bulwahn@43030
   303
    val _ = map check_test_term ts'
bulwahn@43030
   304
    val names = Term.add_free_names (hd ts') []
bulwahn@43030
   305
    val Ts = map snd (Term.add_frees (hd ts') [])
bulwahn@43033
   306
    val current_result = Unsynchronized.ref empty_result
bulwahn@43033
   307
    fun test_card_size test_fun (card, size) =
bulwahn@41291
   308
      (* FIXME: why decrement size by one? *)
bulwahn@42952
   309
      let
bulwahn@42952
   310
        val (ts, timing) = cpu_time ("size " ^ string_of_int size ^ " and card " ^ string_of_int card)
bulwahn@43033
   311
          (fn () => fst (test_fun [card - 1, size - 1]))
bulwahn@42952
   312
        val _ = add_timing timing current_result
bulwahn@42952
   313
      in
bulwahn@42952
   314
        Option.map (pair card) ts
bulwahn@42952
   315
      end
bulwahn@41291
   316
    val enumeration_card_size =
bulwahn@41334
   317
      if forall (fn T => Sign.of_sort thy (T,  ["Enum.enum"])) Ts then
bulwahn@41334
   318
        (* size does not matter *)
bulwahn@41334
   319
        map (rpair 0) (1 upto (length ts))
bulwahn@41334
   320
      else
bulwahn@41334
   321
        (* size does matter *)
bulwahn@41334
   322
        map_product pair (1 upto (length ts)) (1 upto (Config.get ctxt size))
bulwahn@41334
   323
        |> sort (fn ((c1, s1), (c2, s2)) => int_ord ((c1 + s1), (c2 + s2)))
bulwahn@43033
   324
  in
bulwahn@43033
   325
    limit ctxt (limit_time, is_interactive) (fn () =>
bulwahn@43033
   326
      let
bulwahn@43033
   327
        val (test_fun, comp_time) = cpu_time "quickcheck compilation" (fn () => mk_tester ctxt ts)
bulwahn@43033
   328
        val _ = add_timing comp_time current_result
bulwahn@43033
   329
      in
bulwahn@43033
   330
        case test_fun of
bulwahn@43030
   331
          NONE => !current_result
bulwahn@43030
   332
        | SOME test_fun =>
bulwahn@42952
   333
          let
bulwahn@43033
   334
            val _ = case get_first (test_card_size test_fun) enumeration_card_size of
bulwahn@42952
   335
              SOME (card, ts) => add_response names (nth eval_terms (card - 1)) (SOME ts) current_result
bulwahn@42952
   336
            | NONE => ()
bulwahn@43033
   337
          in !current_result end
bulwahn@43033
   338
      end)
bulwahn@43033
   339
      (fn () => (message "Quickcheck ran out of time"; !current_result)) ()
bulwahn@43033
   340
  end
bulwahn@41291
   341
bulwahn@40895
   342
fun get_finite_types ctxt =
bulwahn@40895
   343
  fst (chop (Config.get ctxt finite_type_size)
bulwahn@40895
   344
    (map (Type o rpair []) ["Enum.finite_1", "Enum.finite_2", "Enum.finite_3",
wenzelm@41765
   345
     "Enum.finite_4", "Enum.finite_5"]))
bulwahn@40895
   346
bulwahn@38153
   347
exception WELLSORTED of string
bulwahn@38153
   348
wenzelm@41765
   349
fun monomorphic_term thy insts default_T =
haftmann@28309
   350
  let
haftmann@28309
   351
    fun subst (T as TFree (v, S)) =
bulwahn@41147
   352
      let
bulwahn@41147
   353
        val T' = AList.lookup (op =) insts v
bulwahn@41147
   354
          |> the_default default_T
bulwahn@41147
   355
      in if Sign.of_sort thy (T', S) then T'
wenzelm@41765
   356
        else raise (WELLSORTED ("For instantiation with default_type " ^
wenzelm@41765
   357
          Syntax.string_of_typ_global thy default_T ^
bulwahn@41147
   358
          ":\n" ^ Syntax.string_of_typ_global thy T' ^
bulwahn@41147
   359
          " to be substituted for variable " ^
bulwahn@41147
   360
          Syntax.string_of_typ_global thy T ^ " does not have sort " ^
bulwahn@41147
   361
          Syntax.string_of_sort_global thy S))
bulwahn@41147
   362
      end
haftmann@28309
   363
      | subst T = T;
haftmann@28309
   364
  in (map_types o map_atyps) subst end;
haftmann@28309
   365
bulwahn@42897
   366
datatype wellsorted_error = Wellsorted_Error of string | Term of term * term list
bulwahn@38153
   367
bulwahn@42625
   368
fun test_goal_terms lthy (limit_time, is_interactive) insts check_goals =
haftmann@28309
   369
  let
bulwahn@42897
   370
    fun map_goal_and_eval_terms f (check_goal, eval_terms) = (f check_goal, map f eval_terms)
wenzelm@41765
   371
    val thy = ProofContext.theory_of lthy
bulwahn@41170
   372
    val default_insts =
bulwahn@41170
   373
      if Config.get lthy finite_types then (get_finite_types lthy) else (default_type lthy)
bulwahn@40895
   374
    val inst_goals =
bulwahn@42897
   375
      map (fn (check_goal, eval_terms) =>
bulwahn@41170
   376
        if not (null (Term.add_tfree_names check_goal [])) then
bulwahn@41170
   377
          map (fn T =>
bulwahn@42897
   378
            (pair (SOME T) o Term o apfst (Object_Logic.atomize_term thy))
bulwahn@42897
   379
              (map_goal_and_eval_terms (monomorphic_term thy insts T) (check_goal, eval_terms))
bulwahn@41291
   380
              handle WELLSORTED s => (SOME T, Wellsorted_Error s)) default_insts
bulwahn@41170
   381
        else
bulwahn@42897
   382
          [(NONE, Term (Object_Logic.atomize_term thy check_goal, eval_terms))]) check_goals
wenzelm@41765
   383
    val error_msg =
wenzelm@41765
   384
      cat_lines
wenzelm@41765
   385
        (maps (map_filter (fn (_, Term t) => NONE | (_, Wellsorted_Error s) => SOME s)) inst_goals)
bulwahn@41291
   386
    fun is_wellsorted_term (T, Term t) = SOME (T, t)
bulwahn@41291
   387
      | is_wellsorted_term (_, Wellsorted_Error s) = NONE
bulwahn@38153
   388
    val correct_inst_goals =
bulwahn@41291
   389
      case map (map_filter is_wellsorted_term) inst_goals of
bulwahn@41291
   390
        [[]] => error error_msg
bulwahn@38153
   391
      | xs => xs
bulwahn@40892
   392
    val _ = if Config.get lthy quiet then () else warning error_msg
bulwahn@42952
   393
    fun collect_results f [] results = results
bulwahn@42952
   394
      | collect_results f (t :: ts) results =
bulwahn@42952
   395
        let
bulwahn@42952
   396
          val result = f t
bulwahn@42952
   397
        in
bulwahn@42952
   398
          if found_counterexample result then
bulwahn@42952
   399
            (result :: results)
bulwahn@42952
   400
          else
bulwahn@42952
   401
            collect_results f ts (result :: results)
bulwahn@42952
   402
        end
bulwahn@41291
   403
    fun test_term' goal =
bulwahn@41291
   404
      case goal of
bulwahn@42625
   405
        [(NONE, t)] => test_term lthy (limit_time, is_interactive) t
bulwahn@42625
   406
      | ts => test_term_with_increasing_cardinality lthy (limit_time, is_interactive) (map snd ts)
bulwahn@41291
   407
  in
bulwahn@41291
   408
    if Config.get lthy finite_types then
bulwahn@42952
   409
      collect_results test_term' correct_inst_goals []
bulwahn@41291
   410
    else
bulwahn@42952
   411
      collect_results (test_term lthy (limit_time, is_interactive)) (maps (map snd) correct_inst_goals) []
bulwahn@41291
   412
  end;
bulwahn@38152
   413
bulwahn@42897
   414
fun test_goal (time_limit, is_interactive) (insts, eval_terms) i state =
bulwahn@40896
   415
  let
bulwahn@40896
   416
    val lthy = Proof.context_of state;
bulwahn@40896
   417
    val thy = Proof.theory_of state;
bulwahn@40896
   418
    fun strip (Const ("all", _) $ Abs (_, _, t)) = strip t
bulwahn@40896
   419
      | strip t = t;
bulwahn@40896
   420
    val {goal = st, ...} = Proof.raw_goal state;
bulwahn@40896
   421
    val (gi, frees) = Logic.goal_params (prop_of st) i;
bulwahn@40896
   422
    val some_locale = case (Option.map #target o Named_Target.peek) lthy
bulwahn@40896
   423
     of NONE => NONE
bulwahn@40896
   424
      | SOME "" => NONE
bulwahn@40896
   425
      | SOME locale => SOME locale;
bulwahn@40896
   426
    val assms = if Config.get lthy no_assms then [] else case some_locale
bulwahn@40896
   427
     of NONE => Assumption.all_assms_of lthy
bulwahn@40896
   428
      | SOME locale => Assumption.local_assms_of lthy (Locale.init locale thy);
bulwahn@40896
   429
    val proto_goal = Logic.list_implies (map Thm.term_of assms, subst_bounds (frees, strip gi));
bulwahn@40896
   430
    val check_goals = case some_locale
bulwahn@42897
   431
     of NONE => [(proto_goal, eval_terms)]
bulwahn@42897
   432
      | SOME locale =>
bulwahn@42897
   433
        map (fn (_, phi) => (Morphism.term phi proto_goal, map (Morphism.term phi) eval_terms))
bulwahn@42897
   434
          (Locale.registrations_of (Context.Theory thy) (*FIXME*) locale);
bulwahn@40896
   435
  in
bulwahn@42625
   436
    test_goal_terms lthy (time_limit, is_interactive) insts check_goals
bulwahn@40896
   437
  end
bulwahn@40896
   438
bulwahn@38152
   439
(* pretty printing *)
haftmann@28315
   440
blanchet@40466
   441
fun tool_name auto = (if auto then "Auto " else "") ^ "Quickcheck"
blanchet@40466
   442
blanchet@40466
   443
fun pretty_counterex ctxt auto NONE = Pretty.str (tool_name auto ^ " found no counterexample.")
bulwahn@42899
   444
  | pretty_counterex ctxt auto (SOME (cex, eval_terms)) =
bulwahn@42899
   445
      Pretty.chunks ((Pretty.str (tool_name auto ^ " found a counterexample:\n") ::
haftmann@28315
   446
        map (fn (s, t) =>
bulwahn@42899
   447
          Pretty.block [Pretty.str (s ^ " ="), Pretty.brk 1, Syntax.pretty_term ctxt t]) (rev cex))
bulwahn@42899
   448
        @ (Pretty.str ("Evaluated terms:\n") ::
bulwahn@42899
   449
        map (fn (t, u) =>
bulwahn@42899
   450
          Pretty.block [Syntax.pretty_term ctxt t, Pretty.str " =", Pretty.brk 1, Syntax.pretty_term ctxt u])
bulwahn@42899
   451
          (rev eval_terms)));
haftmann@28315
   452
bulwahn@35378
   453
fun pretty_report (Report {iterations = iterations, raised_match_errors = raised_match_errors,
bulwahn@35378
   454
    satisfied_assms = satisfied_assms, positive_concl_tests = positive_concl_tests}) =
bulwahn@35378
   455
  let
bulwahn@35378
   456
    fun pretty_stat s i = Pretty.block ([Pretty.str (s ^ ": " ^ string_of_int i)])
bulwahn@35378
   457
  in
bulwahn@35378
   458
     ([pretty_stat "iterations" iterations,
bulwahn@35378
   459
     pretty_stat "match exceptions" raised_match_errors]
wenzelm@41765
   460
     @ map_index
wenzelm@41765
   461
       (fn (i, n) => pretty_stat ("satisfied " ^ string_of_int (i + 1) ^ ". assumption") n)
bulwahn@35378
   462
       satisfied_assms
bulwahn@35378
   463
     @ [pretty_stat "positive conclusion tests" positive_concl_tests])
bulwahn@35378
   464
  end
bulwahn@35378
   465
bulwahn@35380
   466
fun pretty_reports ctxt (SOME reports) =
bulwahn@41160
   467
  Pretty.chunks (Pretty.fbrk :: Pretty.str "Quickcheck report:" ::
bulwahn@41153
   468
    maps (fn (size, report) =>
bulwahn@41153
   469
      Pretty.str ("size " ^ string_of_int size ^ ":") :: pretty_report report @ [Pretty.brk 1])
bulwahn@35378
   470
      (rev reports))
bulwahn@35380
   471
  | pretty_reports ctxt NONE = Pretty.str ""
bulwahn@35378
   472
bulwahn@42952
   473
fun pretty_timings timings =
bulwahn@42952
   474
  Pretty.chunks (Pretty.fbrk :: Pretty.str "timings:" ::
bulwahn@42952
   475
    maps (fn (label, time) =>
bulwahn@42952
   476
      Pretty.str (label ^ ": " ^ string_of_int time ^ " ms") :: Pretty.brk 1 :: []) (rev timings))
bulwahn@42952
   477
bulwahn@42952
   478
fun pretty_counterex_and_reports ctxt auto (result :: _) =
bulwahn@42952
   479
  Pretty.chunks (pretty_counterex ctxt auto (response_of result) ::
bulwahn@42952
   480
    (* map (pretty_reports ctxt) (reports_of result) :: *)
bulwahn@42952
   481
    (if Config.get ctxt timing then cons (pretty_timings (timings_of result)) else I) [])
haftmann@28315
   482
haftmann@28315
   483
(* automatic testing *)
haftmann@28309
   484
blanchet@33552
   485
fun auto_quickcheck state =
blanchet@41175
   486
  let
blanchet@41175
   487
    val ctxt = Proof.context_of state;
blanchet@41175
   488
    val res =
blanchet@41175
   489
      state
blanchet@41175
   490
      |> Proof.map_context (Config.put report false #> Config.put quiet true)
bulwahn@42897
   491
      |> try (test_goal (false, false) ([], []) 1);
blanchet@41175
   492
  in
blanchet@41175
   493
    case res of
blanchet@41175
   494
      NONE => (false, state)
bulwahn@42952
   495
    | SOME (result :: _) => if found_counterexample result then
bulwahn@42952
   496
        (true, Proof.goal_message (K (Pretty.chunks [Pretty.str "",
bulwahn@42952
   497
          Pretty.mark Markup.hilite (pretty_counterex ctxt true (response_of result))])) state)
bulwahn@42952
   498
      else
bulwahn@42952
   499
        (false, state)
blanchet@41175
   500
  end
blanchet@33552
   501
blanchet@41175
   502
val setup = Auto_Tools.register_tool (auto, auto_quickcheck)
bulwahn@40892
   503
  #> setup_config
haftmann@28309
   504
wenzelm@30981
   505
(* Isar commands *)
haftmann@28315
   506
haftmann@28336
   507
fun read_nat s = case (Library.read_int o Symbol.explode) s
haftmann@28336
   508
 of (k, []) => if k >= 0 then k
haftmann@28336
   509
      else error ("Not a natural number: " ^ s)
haftmann@28336
   510
  | (_, _ :: _) => error ("Not a natural number: " ^ s);
bulwahn@38149
   511
blanchet@34125
   512
fun read_bool "false" = false
blanchet@34125
   513
  | read_bool "true" = true
blanchet@34125
   514
  | read_bool s = error ("Not a Boolean value: " ^ s)
haftmann@28315
   515
bulwahn@40612
   516
fun read_real s =
bulwahn@40612
   517
  case (Real.fromString s) of
bulwahn@40612
   518
    SOME s => s
bulwahn@40612
   519
  | NONE => error ("Not a real number: " ^ s)
bulwahn@40612
   520
bulwahn@38169
   521
fun read_expectation "no_expectation" = No_Expectation
wenzelm@41765
   522
  | read_expectation "no_counterexample" = No_Counterexample
bulwahn@38169
   523
  | read_expectation "counterexample" = Counterexample
wenzelm@41765
   524
  | read_expectation s = error ("Not an expectation value: " ^ s)
bulwahn@38169
   525
bulwahn@42733
   526
fun valid_tester_name genctxt = AList.defined (op =) (fst (fst (Data.get genctxt)))
bulwahn@41156
   527
bulwahn@41156
   528
fun parse_tester name genctxt =
bulwahn@41156
   529
  if valid_tester_name genctxt name then
bulwahn@41156
   530
    Config.put_generic tester name genctxt
bulwahn@41156
   531
  else
bulwahn@41156
   532
    error ("Unknown tester: " ^ name)
bulwahn@41156
   533
bulwahn@41156
   534
fun parse_test_param ("tester", [arg]) = parse_tester arg
bulwahn@41153
   535
  | parse_test_param ("size", [arg]) = Config.put_generic size (read_nat arg)
bulwahn@40892
   536
  | parse_test_param ("iterations", [arg]) = Config.put_generic iterations (read_nat arg)
bulwahn@40892
   537
  | parse_test_param ("default_type", arg) = (fn gen_ctxt =>
wenzelm@41765
   538
    map_test_params
wenzelm@41765
   539
      ((apfst o K) (map (ProofContext.read_typ (Context.proof_of gen_ctxt)) arg)) gen_ctxt)
bulwahn@40892
   540
  | parse_test_param ("no_assms", [arg]) = Config.put_generic no_assms (read_bool arg)
bulwahn@40892
   541
  | parse_test_param ("expect", [arg]) = map_test_params ((apsnd o K) (read_expectation arg))
bulwahn@40892
   542
  | parse_test_param ("report", [arg]) = Config.put_generic report (read_bool arg)
bulwahn@40892
   543
  | parse_test_param ("quiet", [arg]) = Config.put_generic quiet (read_bool arg)
bulwahn@40892
   544
  | parse_test_param ("timeout", [arg]) = Config.put_generic timeout (read_real arg)
bulwahn@40894
   545
  | parse_test_param ("finite_types", [arg]) = Config.put_generic finite_types (read_bool arg)
wenzelm@41765
   546
  | parse_test_param ("finite_type_size", [arg]) =
wenzelm@41765
   547
    Config.put_generic finite_type_size (read_nat arg)
bulwahn@41156
   548
  | parse_test_param (name, _) = fn genctxt =>
bulwahn@41156
   549
    if valid_tester_name genctxt name then
bulwahn@41156
   550
      Config.put_generic tester name genctxt
bulwahn@41156
   551
    else error ("Unknown tester or test parameter: " ^ name);
haftmann@28315
   552
bulwahn@42896
   553
fun parse_test_param_inst (name, arg) ((insts, eval_terms), ctxt) =
haftmann@28336
   554
      case try (ProofContext.read_typ ctxt) name
bulwahn@42896
   555
       of SOME (TFree (v, _)) =>
bulwahn@42896
   556
         ((AList.update (op =) (v, ProofContext.read_typ ctxt (the_single arg)) insts, eval_terms), ctxt)
bulwahn@42896
   557
        | NONE => (case name of
bulwahn@42896
   558
            "eval" => ((insts, eval_terms @ map (Syntax.read_term ctxt) arg), ctxt)
bulwahn@42896
   559
          | _ => ((insts, eval_terms), Context.proof_map (parse_test_param (name, arg)) ctxt));
haftmann@28315
   560
bulwahn@40892
   561
fun quickcheck_params_cmd args = Context.theory_map (fold parse_test_param args);
wenzelm@41765
   562
bulwahn@42952
   563
fun check_expectation state results =
bulwahn@42952
   564
  (if found_counterexample (hd results) andalso expect (Proof.context_of state) = No_Counterexample
bulwahn@42952
   565
  then
bulwahn@42952
   566
    error ("quickcheck expected to find no counterexample but found one")
bulwahn@42952
   567
  else
bulwahn@42952
   568
    (if not (found_counterexample (hd results)) andalso expect (Proof.context_of state) = Counterexample
bulwahn@42952
   569
    then
bulwahn@42952
   570
      error ("quickcheck expected to find a counterexample but did not find one")
bulwahn@42952
   571
    else ()))
bulwahn@42952
   572
bulwahn@35378
   573
fun gen_quickcheck args i state =
bulwahn@40892
   574
  state
bulwahn@42896
   575
  |> Proof.map_context_result (fn ctxt => fold parse_test_param_inst args (([], []), ctxt))
bulwahn@42897
   576
  |> (fn ((insts, eval_terms), state') => test_goal (true, true) (insts, eval_terms) i state'
bulwahn@42952
   577
  |> tap (check_expectation state'))
boehmes@32295
   578
bulwahn@42952
   579
fun quickcheck args i state = counterexample_of (hd (gen_quickcheck args i state))
bulwahn@35378
   580
boehmes@32295
   581
fun quickcheck_cmd args i state =
bulwahn@35378
   582
  gen_quickcheck args i (Toplevel.proof_of state)
blanchet@40466
   583
  |> Pretty.writeln o pretty_counterex_and_reports (Toplevel.context_of state) false;
haftmann@28309
   584
wenzelm@41765
   585
val parse_arg =
wenzelm@41765
   586
  Parse.name --
wenzelm@41765
   587
    (Scan.optional (Parse.$$$ "=" |--
wenzelm@41765
   588
      (((Parse.name || Parse.float_number) >> single) ||
wenzelm@41765
   589
        (Parse.$$$ "[" |-- Parse.list1 Parse.name --| Parse.$$$ "]"))) ["true"]);
haftmann@28309
   590
wenzelm@41765
   591
val parse_args =
wenzelm@41765
   592
  Parse.$$$ "[" |-- Parse.list1 parse_arg --| Parse.$$$ "]" || Scan.succeed [];
haftmann@28336
   593
wenzelm@36970
   594
val _ =
wenzelm@36970
   595
  Outer_Syntax.command "quickcheck_params" "set parameters for random testing" Keyword.thy_decl
wenzelm@36970
   596
    (parse_args >> (fn args => Toplevel.theory (quickcheck_params_cmd args)));
haftmann@28309
   597
wenzelm@36970
   598
val _ =
wenzelm@36970
   599
  Outer_Syntax.improper_command "quickcheck" "try to find counterexample for subgoal" Keyword.diag
wenzelm@36970
   600
    (parse_args -- Scan.optional Parse.nat 1
wenzelm@36970
   601
      >> (fn (args, i) => Toplevel.no_timing o Toplevel.keep (quickcheck_cmd args i)));
haftmann@28309
   602
haftmann@28309
   603
end;
haftmann@28256
   604
haftmann@28315
   605
haftmann@28315
   606
val auto_quickcheck = Quickcheck.auto;