src/Tools/quickcheck.ML
author wenzelm
Fri Oct 29 11:07:21 2010 +0200 (2010-10-29)
changeset 40253 f99ec71de82d
parent 40246 c03fc7d3fa97
parent 40235 87998864284e
child 40366 a2866dbfbe6b
permissions -rw-r--r--
merged
     1 (*  Title:      Tools/quickcheck.ML
     2     Author:     Stefan Berghofer, Florian Haftmann, Lukas Bulwahn, TU Muenchen
     3 
     4 Generic counterexample search engine.
     5 *)
     6 
     7 signature QUICKCHECK =
     8 sig
     9   val setup: theory -> theory
    10   (* configuration *)
    11   val auto: bool Unsynchronized.ref
    12   val timing : bool Unsynchronized.ref
    13   datatype report = Report of
    14     { iterations : int, raised_match_errors : int,
    15       satisfied_assms : int list, positive_concl_tests : int }
    16   datatype expectation = No_Expectation | No_Counterexample | Counterexample;
    17   datatype test_params = Test_Params of
    18   { size: int, iterations: int, default_type: typ list, no_assms: bool,
    19     expect : expectation, report: bool, quiet : bool, timeout : int};
    20   val test_params_of : Proof.context -> test_params
    21   val report : Proof.context -> bool
    22   val map_test_params :
    23     ((int * int) * ((typ list * bool) * ((expectation * bool) * (bool * int)))
    24       -> (int * int) * ((typ list * bool) * ((expectation * bool) * (bool * int))))
    25     -> Context.generic -> Context.generic
    26   val add_generator:
    27     string * (Proof.context -> term -> int -> term list option * (bool list * bool))
    28       -> Context.generic -> Context.generic
    29   (* testing terms and proof states *)
    30   val test_term: Proof.context -> string option -> term ->
    31     (string * term) list option * ((string * int) list * ((int * report list) list) option)
    32   val quickcheck: (string * string list) list -> int -> Proof.state -> (string * term) list option
    33 end;
    34 
    35 structure Quickcheck : QUICKCHECK =
    36 struct
    37 
    38 (* preferences *)
    39 
    40 val auto = Unsynchronized.ref false;
    41 
    42 val timing = Unsynchronized.ref false;
    43 
    44 val _ =
    45   ProofGeneralPgip.add_preference Preferences.category_tracing
    46   (Unsynchronized.setmp auto true (fn () =>
    47     Preferences.bool_pref auto
    48       "auto-quickcheck"
    49       "Run Quickcheck automatically.") ());
    50 
    51 (* quickcheck report *)
    52 
    53 datatype single_report = Run of bool list * bool | MatchExc
    54 
    55 datatype report = Report of
    56   { iterations : int, raised_match_errors : int,
    57     satisfied_assms : int list, positive_concl_tests : int }
    58 
    59 fun collect_single_report single_report
    60     (Report {iterations = iterations, raised_match_errors = raised_match_errors,
    61     satisfied_assms = satisfied_assms, positive_concl_tests = positive_concl_tests}) =
    62   case single_report
    63   of MatchExc =>
    64     Report {iterations = iterations + 1, raised_match_errors = raised_match_errors + 1,
    65       satisfied_assms = satisfied_assms, positive_concl_tests = positive_concl_tests}
    66    | Run (assms, concl) =>
    67     Report {iterations = iterations + 1, raised_match_errors = raised_match_errors,
    68       satisfied_assms =
    69         map2 (fn b => fn s => if b then s + 1 else s) assms
    70          (if null satisfied_assms then replicate (length assms) 0 else satisfied_assms),
    71       positive_concl_tests = if concl then positive_concl_tests + 1 else positive_concl_tests}
    72 
    73 (* expectation *)
    74 
    75 datatype expectation = No_Expectation | No_Counterexample | Counterexample; 
    76 
    77 fun merge_expectation (expect1, expect2) =
    78   if expect1 = expect2 then expect1 else No_Expectation
    79 
    80 (* quickcheck configuration -- default parameters, test generators *)
    81 
    82 datatype test_params = Test_Params of
    83   { size: int, iterations: int, default_type: typ list, no_assms: bool,
    84     expect : expectation, report: bool, quiet : bool, timeout : int};
    85 
    86 fun dest_test_params
    87     (Test_Params { size, iterations, default_type, no_assms, expect, report, quiet, timeout }) =
    88   ((size, iterations), ((default_type, no_assms), ((expect, report), (quiet, timeout))));
    89 
    90 fun make_test_params
    91     ((size, iterations), ((default_type, no_assms), ((expect, report), (quiet, timeout)))) =
    92   Test_Params { size = size, iterations = iterations, default_type = default_type,
    93     no_assms = no_assms, expect = expect, report = report, quiet = quiet, timeout = timeout };
    94 
    95 fun map_test_params' f
    96     (Test_Params { size, iterations, default_type, no_assms, expect, report, quiet, timeout }) =
    97   make_test_params
    98     (f ((size, iterations), ((default_type, no_assms), ((expect, report), (quiet, timeout)))));
    99 
   100 fun merge_test_params
   101  (Test_Params { size = size1, iterations = iterations1, default_type = default_type1,
   102     no_assms = no_assms1, expect = expect1, report = report1, quiet = quiet1, timeout = timeout1 },
   103   Test_Params { size = size2, iterations = iterations2, default_type = default_type2,
   104     no_assms = no_assms2, expect = expect2, report = report2, quiet = quiet2, timeout = timeout2}) =
   105   make_test_params ((Int.max (size1, size2), Int.max (iterations1, iterations2)),
   106     ((merge (op =) (default_type1, default_type2), no_assms1 orelse no_assms2),
   107     ((merge_expectation (expect1, expect2), report1 orelse report2),
   108     (quiet1 orelse quiet2, Int.min (timeout1, timeout2)))));
   109 
   110 structure Data = Generic_Data
   111 (
   112   type T =
   113     (string * (Proof.context -> term -> int -> term list option * (bool list * bool))) list
   114       * test_params;
   115   val empty = ([], Test_Params
   116     { size = 10, iterations = 100, default_type = [], no_assms = false,
   117       expect = No_Expectation, report = false, quiet = false, timeout = 30});
   118   val extend = I;
   119   fun merge ((generators1, params1), (generators2, params2)) : T =
   120     (AList.merge (op =) (K true) (generators1, generators2),
   121       merge_test_params (params1, params2));
   122 );
   123 
   124 val test_params_of = snd o Data.get o Context.Proof;
   125 
   126 val size = fst o fst o dest_test_params o test_params_of
   127 
   128 val iterations = snd o fst o dest_test_params o test_params_of
   129 
   130 val default_type = fst o fst o snd o dest_test_params o test_params_of
   131 
   132 val no_assms = snd o fst o snd o dest_test_params o test_params_of
   133 
   134 val expect = fst o fst o snd o snd o dest_test_params o test_params_of
   135 
   136 val report = snd o fst o snd o snd o dest_test_params o test_params_of
   137 
   138 val quiet = fst o snd o snd o snd o dest_test_params o test_params_of
   139 
   140 val timeout = snd o snd o snd o snd o dest_test_params o test_params_of
   141 
   142 fun map_report f
   143   (Test_Params { size, iterations, default_type, no_assms, expect, report, quiet, timeout }) =
   144     make_test_params
   145       ((size, iterations), ((default_type, no_assms), ((expect, f report), (quiet, timeout))));
   146 
   147 fun map_quiet f
   148   (Test_Params { size, iterations, default_type, no_assms, expect, report, quiet, timeout }) =
   149     make_test_params
   150       ((size, iterations), ((default_type, no_assms), ((expect, report), (f quiet, timeout))));
   151     
   152 fun set_report report = Data.map (apsnd (map_report (K report)))
   153 
   154 fun set_quiet quiet = Data.map (apsnd (map_quiet (K quiet)))
   155 
   156 val map_test_params = Data.map o apsnd o map_test_params'
   157 
   158 val add_generator = Data.map o apfst o AList.update (op =);
   159 
   160 (* generating tests *)
   161 
   162 fun mk_tester_select name ctxt =
   163   case AList.lookup (op =) ((fst o Data.get o Context.Proof) ctxt) name
   164    of NONE => error ("No such quickcheck generator: " ^ name)
   165     | SOME generator => generator ctxt;
   166 
   167 fun mk_testers ctxt t =
   168   (map snd o fst o Data.get o Context.Proof) ctxt
   169   |> map_filter (fn generator => try (generator ctxt) t);
   170 
   171 fun mk_testers_strict ctxt t =
   172   let
   173     val generators = ((map snd o fst o Data.get o Context.Proof) ctxt)
   174     val testers = map (fn generator => Exn.interruptible_capture (generator ctxt) t) generators;
   175   in
   176     if forall (is_none o Exn.get_result) testers
   177     then [(Exn.release o snd o split_last) testers]
   178     else map_filter Exn.get_result testers
   179   end;
   180 
   181 
   182 (* testing propositions *)
   183 
   184 fun prep_test_term t =
   185   let
   186     val _ = (null (Term.add_tvars t []) andalso null (Term.add_tfrees t [])) orelse
   187       error "Term to be tested contains type variables";
   188     val _ = null (Term.add_vars t []) orelse
   189       error "Term to be tested contains schematic variables";
   190     val frees = Term.add_frees t [];
   191   in (map fst frees, list_abs_free (frees, t)) end
   192 
   193 fun cpu_time description f =
   194   let
   195     val start = start_timing ()
   196     val result = Exn.capture f ()
   197     val time = Time.toMilliseconds (#cpu (end_timing start))
   198   in (Exn.release result, (description, time)) end
   199 
   200 fun test_term ctxt generator_name t =
   201   let
   202     val (names, t') = prep_test_term t;
   203     val (testers, comp_time) = cpu_time "quickcheck compilation"
   204       (fn () => (case generator_name
   205        of NONE => if quiet ctxt then mk_testers ctxt t' else mk_testers_strict ctxt t'
   206         | SOME name => [mk_tester_select name ctxt t']));
   207     fun iterate f 0 report = (NONE, report)
   208       | iterate f j report =
   209         let
   210           val (test_result, single_report) = apsnd Run (f ()) handle Match => (if quiet ctxt then ()
   211              else warning "Exception Match raised during quickcheck"; (NONE, MatchExc))
   212           val report = collect_single_report single_report report
   213         in
   214           case test_result of NONE => iterate f (j - 1) report | SOME q => (SOME q, report)
   215         end
   216     val empty_report = Report { iterations = 0, raised_match_errors = 0,
   217       satisfied_assms = [], positive_concl_tests = 0 }
   218     fun with_testers k [] = (NONE, [])
   219       | with_testers k (tester :: testers) =
   220           case iterate (fn () => tester (k - 1)) (iterations ctxt) empty_report
   221            of (NONE, report) => apsnd (cons report) (with_testers k testers)
   222             | (SOME q, report) => (SOME q, [report]);
   223     fun with_size k reports =
   224       if k > size ctxt then (NONE, reports)
   225       else
   226        (if quiet ctxt then () else Output.urgent_message ("Test data size: " ^ string_of_int k);
   227         let
   228           val (result, new_report) = with_testers k testers
   229           val reports = ((k, new_report) :: reports)
   230         in case result of NONE => with_size (k + 1) reports | SOME q => (SOME q, reports) end);
   231     val ((result, reports), exec_time) =
   232       TimeLimit.timeLimit (Time.fromSeconds (timeout ctxt)) (fn () => cpu_time "quickcheck execution"
   233       (fn () => apfst
   234          (fn result => case result of NONE => NONE
   235         | SOME ts => SOME (names ~~ ts)) (with_size 1 []))) ()
   236       handle TimeLimit.TimeOut => error "Reached timeout during Quickcheck"
   237   in
   238     (result, ([exec_time, comp_time], if report ctxt then SOME reports else NONE))
   239   end;
   240 
   241 exception WELLSORTED of string
   242 
   243 fun monomorphic_term thy insts default_T = 
   244   let
   245     fun subst (T as TFree (v, S)) =
   246           let
   247             val T' = AList.lookup (op =) insts v
   248               |> the_default default_T
   249           in if Sign.of_sort thy (T', S) then T'
   250             else raise (WELLSORTED ("For instantiation with default_type " ^ Syntax.string_of_typ_global thy default_T ^
   251               ":\n" ^ Syntax.string_of_typ_global thy T' ^
   252               " to be substituted for variable " ^
   253               Syntax.string_of_typ_global thy T ^ " does not have sort " ^
   254               Syntax.string_of_sort_global thy S))
   255           end
   256       | subst T = T;
   257   in (map_types o map_atyps) subst end;
   258 
   259 datatype wellsorted_error = Wellsorted_Error of string | Term of term
   260 
   261 fun test_goal generator_name insts i state =
   262   let
   263     val lthy = Proof.context_of state;
   264     val thy = Proof.theory_of state;
   265     fun strip (Const ("all", _) $ Abs (_, _, t)) = strip t
   266       | strip t = t;
   267     val {goal = st, ...} = Proof.raw_goal state;
   268     val (gi, frees) = Logic.goal_params (prop_of st) i;
   269     val some_locale = case (Option.map #target o Named_Target.peek) lthy
   270      of NONE => NONE
   271       | SOME "" => NONE
   272       | SOME locale => SOME locale;
   273     val assms = if no_assms lthy then [] else case some_locale
   274      of NONE => Assumption.all_assms_of lthy
   275       | SOME locale => Assumption.local_assms_of lthy (Locale.init locale thy);
   276     val proto_goal = Logic.list_implies (map Thm.term_of assms, subst_bounds (frees, strip gi));
   277     val check_goals = case some_locale
   278      of NONE => [proto_goal]
   279       | SOME locale => map (fn (_, phi) => Morphism.term phi proto_goal)
   280         (Locale.registrations_of (Context.Theory thy) (*FIXME*) locale);
   281     val inst_goals = maps (fn check_goal => map (fn T =>
   282       Term ((Object_Logic.atomize_term thy o monomorphic_term thy insts T) check_goal)
   283         handle WELLSORTED s => Wellsorted_Error s) (default_type lthy)) check_goals
   284     val error_msg = cat_lines (map_filter (fn Term t => NONE | Wellsorted_Error s => SOME s) inst_goals)
   285     val correct_inst_goals =
   286       case map_filter (fn Term t => SOME t | Wellsorted_Error s => NONE) inst_goals of
   287         [] => error error_msg
   288       | xs => xs
   289     val _ = if quiet lthy then () else warning error_msg
   290     fun collect_results f reports [] = (NONE, rev reports)
   291       | collect_results f reports (t :: ts) =
   292         case f t of
   293           (SOME res, report) => (SOME res, rev (report :: reports))
   294         | (NONE, report) => collect_results f (report :: reports) ts
   295   in collect_results (test_term lthy generator_name) [] correct_inst_goals end;
   296 
   297 (* pretty printing *)
   298 
   299 fun tool_name auto = (if auto then "Auto " else "") ^ "Quickcheck"
   300 
   301 fun pretty_counterex ctxt auto NONE = Pretty.str (tool_name auto ^ " found no counterexample.")
   302   | pretty_counterex ctxt auto (SOME cex) =
   303       Pretty.chunks (Pretty.str (tool_name auto ^ " found a counterexample:\n") ::
   304         map (fn (s, t) =>
   305           Pretty.block [Pretty.str (s ^ " ="), Pretty.brk 1, Syntax.pretty_term ctxt t]) cex);
   306 
   307 fun pretty_report (Report {iterations = iterations, raised_match_errors = raised_match_errors,
   308     satisfied_assms = satisfied_assms, positive_concl_tests = positive_concl_tests}) =
   309   let
   310     fun pretty_stat s i = Pretty.block ([Pretty.str (s ^ ": " ^ string_of_int i)])
   311   in
   312      ([pretty_stat "iterations" iterations,
   313      pretty_stat "match exceptions" raised_match_errors]
   314      @ map_index (fn (i, n) => pretty_stat ("satisfied " ^ string_of_int (i + 1) ^ ". assumption") n)
   315        satisfied_assms
   316      @ [pretty_stat "positive conclusion tests" positive_concl_tests])
   317   end
   318 
   319 fun pretty_reports' [report] = [Pretty.chunks (pretty_report report)]
   320   | pretty_reports' reports =
   321   map_index (fn (i, report) =>
   322     Pretty.chunks (Pretty.str (string_of_int (i + 1) ^ ". generator:\n") :: pretty_report report))
   323     reports
   324 
   325 fun pretty_reports ctxt (SOME reports) =
   326   Pretty.chunks (Pretty.str "Quickcheck report:" ::
   327     maps (fn (size, reports) =>
   328       Pretty.str ("size " ^ string_of_int size ^ ":") :: pretty_reports' reports @ [Pretty.brk 1])
   329       (rev reports))
   330   | pretty_reports ctxt NONE = Pretty.str ""
   331 
   332 fun pretty_counterex_and_reports ctxt auto (cex, timing_and_reports) =
   333   Pretty.chunks (pretty_counterex ctxt auto cex ::
   334     map (pretty_reports ctxt) (map snd timing_and_reports))
   335 
   336 (* automatic testing *)
   337 
   338 fun auto_quickcheck state =
   339   if not (!auto) then
   340     (false, state)
   341   else
   342     let
   343       val ctxt = Proof.context_of state;
   344       val res =
   345         state
   346         |> Proof.map_context (Context.proof_map (set_report false #> set_quiet true))
   347         |> try (test_goal NONE [] 1);
   348     in
   349       case res of
   350         NONE => (false, state)
   351       | SOME (NONE, report) => (false, state)
   352       | SOME (cex, report) => (true, Proof.goal_message (K (Pretty.chunks [Pretty.str "",
   353           Pretty.mark Markup.hilite (pretty_counterex ctxt true cex)])) state)
   354     end
   355 
   356 val setup = Auto_Tools.register_tool ("quickcheck", auto_quickcheck)
   357 
   358 
   359 (* Isar commands *)
   360 
   361 fun read_nat s = case (Library.read_int o Symbol.explode) s
   362  of (k, []) => if k >= 0 then k
   363       else error ("Not a natural number: " ^ s)
   364   | (_, _ :: _) => error ("Not a natural number: " ^ s);
   365 
   366 fun read_bool "false" = false
   367   | read_bool "true" = true
   368   | read_bool s = error ("Not a Boolean value: " ^ s)
   369 
   370 fun read_expectation "no_expectation" = No_Expectation
   371   | read_expectation "no_counterexample" = No_Counterexample 
   372   | read_expectation "counterexample" = Counterexample
   373   | read_expectation s = error ("Not an expectation value: " ^ s)  
   374 
   375 fun parse_test_param ctxt ("size", [arg]) =
   376       (apfst o apfst o K) (read_nat arg)
   377   | parse_test_param ctxt ("iterations", [arg]) =
   378       (apfst o apsnd o K) (read_nat arg)
   379   | parse_test_param ctxt ("default_type", arg) =
   380       (apsnd o apfst o apfst o K) (map (ProofContext.read_typ ctxt) arg)
   381   | parse_test_param ctxt ("no_assms", [arg]) =
   382       (apsnd o apfst o apsnd o K) (read_bool arg)
   383   | parse_test_param ctxt ("expect", [arg]) =
   384       (apsnd o apsnd o apfst o apfst o K) (read_expectation arg)
   385   | parse_test_param ctxt ("report", [arg]) =
   386       (apsnd o apsnd o apfst o apsnd o K) (read_bool arg)
   387   | parse_test_param ctxt ("quiet", [arg]) =
   388       (apsnd o apsnd o apsnd o apfst o K) (read_bool arg)
   389   | parse_test_param ctxt ("timeout", [arg]) =
   390       (apsnd o apsnd o apsnd o apsnd o K) (read_nat arg)
   391   | parse_test_param ctxt (name, _) =
   392       error ("Unknown test parameter: " ^ name);
   393 
   394 fun parse_test_param_inst ctxt ("generator", [arg]) =
   395       (apsnd o apfst o K o SOME) arg
   396   | parse_test_param_inst ctxt (name, arg) =
   397       case try (ProofContext.read_typ ctxt) name
   398        of SOME (TFree (v, _)) => (apsnd o apsnd o AList.update (op =))
   399               (v, ProofContext.read_typ ctxt (the_single arg))
   400         | _ => (apfst o parse_test_param ctxt) (name, arg);
   401 
   402 fun quickcheck_params_cmd args thy =
   403   let
   404     val ctxt = ProofContext.init_global thy
   405     val f = fold (parse_test_param ctxt) args;
   406   in
   407     thy
   408     |> (Context.theory_map o map_test_params) f
   409   end;
   410 
   411 fun gen_quickcheck args i state =
   412   let
   413     val ctxt = Proof.context_of state;
   414     val default_params = (dest_test_params o snd o Data.get o Context.Proof) ctxt;
   415     val f = fold (parse_test_param_inst ctxt) args;
   416     val (test_params, (generator_name, insts)) = f (default_params, (NONE, []));
   417   in
   418     state
   419     |> Proof.map_context (Context.proof_map (map_test_params (K test_params)))
   420     |> (fn state' => test_goal generator_name insts i state'
   421       |> tap (fn (SOME x, _) => if expect (Proof.context_of state') = No_Counterexample then
   422                  error ("quickcheck expected to find no counterexample but found one") else ()
   423              | (NONE, _) => if expect (Proof.context_of state') = Counterexample then
   424                  error ("quickcheck expected to find a counterexample but did not find one") else ()))
   425   end;
   426 
   427 fun quickcheck args i state = fst (gen_quickcheck args i state);
   428 
   429 fun quickcheck_cmd args i state =
   430   gen_quickcheck args i (Toplevel.proof_of state)
   431   |> Pretty.writeln o pretty_counterex_and_reports (Toplevel.context_of state) false;
   432 
   433 val parse_arg = Parse.name -- (Scan.optional (Parse.$$$ "=" |-- 
   434   ((Parse.name >> single) || (Parse.$$$ "[" |-- Parse.list1 Parse.name --| Parse.$$$ "]"))) ["true"]);
   435 
   436 val parse_args = Parse.$$$ "[" |-- Parse.list1 parse_arg --| Parse.$$$ "]"
   437   || Scan.succeed [];
   438 
   439 val _ =
   440   Outer_Syntax.command "quickcheck_params" "set parameters for random testing" Keyword.thy_decl
   441     (parse_args >> (fn args => Toplevel.theory (quickcheck_params_cmd args)));
   442 
   443 val _ =
   444   Outer_Syntax.improper_command "quickcheck" "try to find counterexample for subgoal" Keyword.diag
   445     (parse_args -- Scan.optional Parse.nat 1
   446       >> (fn (args, i) => Toplevel.no_timing o Toplevel.keep (quickcheck_cmd args i)));
   447 
   448 end;
   449 
   450 
   451 val auto_quickcheck = Quickcheck.auto;