(* Title: HOL/Tools/Quickcheck/quickcheck_common.ML Author: Florian Haftmann, Lukas Bulwahn, TU Muenchen
Common functions for quickcheck's generators.
*)
signature QUICKCHECK_COMMON = sig val compat_prefs : BNF_LFP_Compat.preference list val strip_imp : term -> (term list * term) val reflect_bool : bool -> term val define_functions : ((term list -> term list) * (Proof.context -> tactic) option)
-> string -> stringlist -> stringlist -> typ list -> Proof.context -> Proof.context val perhaps_constrain: theory -> (typ * sort) list -> (string * sort) list
-> (string * sort -> string * sort) option val instantiate_goals: Proof.context -> (string * typ) list -> (term * term list) list
-> (typ option * (term * term list)) listlist val register_predicate : term * string -> Context.generic -> Context.generic val mk_safe_if : term -> term -> term * term * (bool -> term) -> bool -> term val collect_results : ('a -> Quickcheck.result) -> 'a list ->
Quickcheck.result list -> Quickcheck.result list type result = (bool * term list) option * Quickcheck.report option type generator = string * ((theory -> typ list -> bool) *
(Proof.context -> (term * term list) list -> bool -> int list -> result)) val generator_test_goal_terms :
generator -> Proof.context -> bool -> (string * typ) list
-> (term * term list) list -> Quickcheck.result list type instantiation =
Old_Datatype_Aux.config -> Old_Datatype_Aux.descr -> (string * sort) list -> stringlist -> string -> stringlist * stringlist -> typ list * typ list -> theory -> theory val ensure_sort :
(((sort * sort) * sort) *
((theory -> stringlist -> Old_Datatype_Aux.descr * (string * sort) list * stringlist
* string * (stringlist * stringlist) * (typ list * typ list)) * instantiation)) ->
Old_Datatype_Aux.config -> stringlist -> theory -> theory val ensure_common_sort_datatype : (sort * instantiation) -> Old_Datatype_Aux.config -> stringlist -> theory -> theory val datatype_interpretation : string -> sort * instantiation -> theory -> theory val gen_mk_parametric_generator_expr :
(((Proof.context -> term * term list -> term) * term) * typ) ->
Proof.context -> (term * term list) list -> term val mk_fun_upd : typ -> typ -> term * term -> term -> term val post_process_term : term -> term val test_term : generator -> Proof.context -> bool -> term * term list -> Quickcheck.result end
fun strip_imp (Const(\<^const_name>\<open>HOL.implies\<close>, _) $ A $ B) = apfst (cons A) (strip_imp B)
| strip_imp A = ([], A)
fun reflect_bool b = if b then \<^term>\<open>True\<close> else \<^term>\<open>False\<close>
fun mk_undefined T = Const (\<^const_name>\<open>undefined\<close>, T)
(* testing functions: testing with increasing sizes (and cardinalities) *)
type result = (bool * term list) option * Quickcheck.report option type generator = string * ((theory -> typ list -> bool) *
(Proof.context -> (term * term list) list -> bool -> int list -> result))
fun check_test_term t = let val _ =
(null (Term.add_tvars t []) andalso null (Term.add_tfrees t [])) orelse
error "Term to be tested contains type variables" val _ =
null (Term.add_vars t []) orelse
error "Term to be tested contains schematic variables" in () end
fun cpu_time description e = letval ({cpu, ...}, result) = Timing.timing e () in (result, (description, Time.toMilliseconds cpu)) end
fun test_term (name, (_, compile)) ctxt catch_code_errors (t, eval_terms) = let val genuine_only = Config.get ctxt Quickcheck.genuine_only val abort_potential = Config.get ctxt Quickcheck.abort_potential val _ = check_test_term t val names = Term.add_free_names t [] val current_size = Unsynchronized.ref 0 val current_result = Unsynchronized.ref Quickcheck.empty_result val act = if catch_code_errors thentryelse (fn f => SOME o f) val (test_fun, comp_time) =
cpu_time "quickcheck compilation" (fn () => act (compile ctxt) [(t, eval_terms)]) val _ = Quickcheck.add_timing comp_time current_result fun with_size test_fun genuine_only k = if k > Config.get ctxt Quickcheck.sizethen NONE else let val _ =
Quickcheck.verbose_message ctxt
("[Quickcheck-" ^ name ^ "] Test data size: " ^ string_of_int k) val _ = current_size := k val ((result, report), time) =
cpu_time ("size " ^ string_of_int k) (fn () => test_fun genuine_only [1, k - 1]) val _ = if Config.get ctxt Quickcheck.timing then
Quickcheck.verbose_message ctxt (fst time ^ ": " ^ string_of_int (snd time) ^ " ms") else () val _ = Quickcheck.add_timing time current_result val _ = Quickcheck.add_report k report current_result in
(case result of
NONE => with_size test_fun genuine_only (k + 1)
| SOME (true, ts) => SOME (true, ts)
| SOME (false, ts) => if abort_potential then SOME (false, ts) else let val (ts1, ts2) = chop (length names) ts val (eval_terms', _) = chop (length ts2) eval_terms val cex = SOME ((false, names ~~ ts1), eval_terms' ~~ ts2) in
Quickcheck.message ctxt
(Pretty.string_of (Quickcheck.pretty_counterex ctxt false cex));
Quickcheck.message ctxt "Quickcheck continues to find a genuine counterexample...";
with_size test_fun true k end) end in case test_fun of
NONE =>
(Quickcheck.message ctxt ("Conjecture is not executable with Quickcheck-" ^ name);
!current_result)
| SOME test_fun => let val _ = Quickcheck.message ctxt ("Testing conjecture with Quickcheck-" ^ name ^ "...") val (response, exec_time) =
cpu_time "quickcheck execution" (fn () => with_size test_fun genuine_only 1) val _ = Quickcheck.add_response names eval_terms response current_result val _ = Quickcheck.add_timing exec_time current_result in !current_result end end
fun test_term_with_cardinality (name, (size_matters_for, compile)) ctxt catch_code_errors ts = let val genuine_only = Config.get ctxt Quickcheck.genuine_only val abort_potential = Config.get ctxt Quickcheck.abort_potential val thy = Proof_Context.theory_of ctxt val (ts', eval_terms) = split_list ts val _ = map check_test_term ts' val names = Term.add_free_names (hd ts') [] val Ts = map snd (Term.add_frees (hd ts') []) val current_result = Unsynchronized.ref Quickcheck.empty_result fun test_card_size test_fun genuine_only (card, size) = (* FIXME: why decrement size by one? *) let val _ =
Quickcheck.verbose_message ctxt ("[Quickcheck-" ^ name ^ "] Test " ^
(ifsize = 0 then""else"data size: " ^ string_of_int size ^ " and ") ^ "cardinality: " ^ string_of_int card) val (ts, timing) =
cpu_time ("size " ^ string_of_int size ^ " and card " ^ string_of_int card)
(fn () => fst (test_fun genuine_only [card, size + 1])) val _ = Quickcheck.add_timing timing current_result inOption.map (pair (card, size)) ts end val enumeration_card_size = if size_matters_for thy Ts then
map_product pair (1 upto (length ts)) (1 upto (Config.get ctxt Quickcheck.size))
|> sort (fn ((c1, s1), (c2, s2)) => int_ord ((c1 + s1), (c2 + s2))) elsemap (rpair 0) (1 upto (length ts)) val act = if catch_code_errors thentryelse (fn f => SOME o f) val (test_fun, comp_time) = cpu_time "quickcheck compilation" (fn () => act (compile ctxt) ts) val _ = Quickcheck.add_timing comp_time current_result in
(case test_fun of
NONE =>
(Quickcheck.message ctxt ("Conjecture is not executable with Quickcheck-" ^ name);
!current_result)
| SOME test_fun => let val _ = Quickcheck.message ctxt ("Testing conjecture with Quickcheck-" ^ name ^ "...") funtest genuine_only enum =
(case get_first (test_card_size test_fun genuine_only) enum of
SOME ((card, _), (true, ts)) =>
Quickcheck.add_response names (nth eval_terms (card - 1))
(SOME (true, ts)) current_result
| SOME ((card, size), (false, ts)) => if abort_potential then
Quickcheck.add_response names (nth eval_terms (card - 1))
(SOME (false, ts)) current_result else let val (ts1, ts2) = chop (length names) ts val (eval_terms', _) = chop (length ts2) (nth eval_terms (card - 1)) val cex = SOME ((false, names ~~ ts1), eval_terms' ~~ ts2) in
Quickcheck.message ctxt
(Pretty.string_of (Quickcheck.pretty_counterex ctxt false cex));
Quickcheck.message ctxt "Quickcheck continues to find a genuine counterexample..."; testtrue (drop_prefix (fn x => not (x = (card, size))) enum) end
| NONE => ()) in (test genuine_only enumeration_card_size; !current_result) end) end
fun monomorphic_term ctxt insts default_T =
(map_types o map_atyps)
(fn T as TFree (v, S) => letval T' = AList.lookup (op =) insts v |> the_default default_T in if Sign.of_sort (Proof_Context.theory_of ctxt) (T', S) then T' else raise WELLSORTED ("For instantiation with default_type " ^
Syntax.string_of_typ ctxt default_T ^ ":\n" ^ Syntax.string_of_typ ctxt T' ^ " to be substituted for variable " ^ Syntax.string_of_typ ctxt T ^ " does not have sort " ^ Syntax.string_of_sort ctxt S) end
| T => T)
datatype wellsorted_error = Wellsorted_Error ofstring | Term of term * term list
(* minimalistic preprocessing *)
fun strip_all (Const (\<^const_name>\<open>HOL.All\<close>, _) $ Abs (a, T, t)) = letval (a', t') = strip_all t in ((a, T) :: a', t') end
| strip_all t = ([], t)
fun preprocess ctxt t = let val thy = Proof_Context.theory_of ctxt val dest = HOLogic.dest_eq o HOLogic.dest_Trueprop o Thm.prop_of val rewrs = map (swap o dest) @{thms all_simps} @
(map dest [@{thm not_ex}, @{thm not_all}, @{thm imp_conjL}, @{thm fun_eq_iff},
@{thm bot_fun_def}, @{thm less_bool_def}]) val t' = Pattern.rewrite_term thy rewrs [] (Object_Logic.atomize_term ctxt t) val (vs, body) = strip_all t' val vs' = Variable.variant_names (Variable.declare_names t' ctxt) vs in subst_bounds (map Free (rev vs'), body) end
structure Subtype_Predicates = Generic_Data
( type T = (term * string) list val empty = [] fun merge data : T = AList.merge (op =) (K true) data
)
val register_predicate = Subtype_Predicates.map o AList.update (op =)
fun subtype_preprocess ctxt (T, (t, ts)) = let val preds = Subtype_Predicates.get (Context.Proof ctxt) fun matches (p $ _) = AList.defined Term.could_unify preds p fun get_match (p $ x) = Option.map (rpair x) (AList.lookup Term.could_unify preds p) fun subst_of (tyco, v as Free (x, repT)) = let val [(info, _)] = Typedef.get_info ctxt tyco val repT' = Logic.varifyT_global (#rep_type info) val substT = Sign.typ_match (Proof_Context.theory_of ctxt) (repT', repT) Vartab.empty val absT = Envir.subst_type substT (Logic.varifyT_global (#abs_type info)) in (v, Const (#Rep_name info, absT --> repT) $ Free (x, absT)) end val (prems, concl) = strip_imp t val subst = map subst_of (map_filter get_match prems) val t' = Term.subst_free subst
(fold_rev (curry HOLogic.mk_imp) (filter_out matches prems) concl) in (T, (t', ts)) end
(* instantiation of type variables with concrete types *)
fun instantiate_goals ctxt insts goals = let fun map_goal_and_eval_terms f (check_goal, eval_terms) = (f check_goal, map f eval_terms) val default_insts = if Config.get ctxt Quickcheck.finite_types then get_finite_types else Quickcheck.default_type val inst_goals = map (fn (check_goal, eval_terms) => ifnot (null (Term.add_tfree_names check_goal [])) then map (fn T =>
(pair (SOME T) o Term o apfst (preprocess ctxt))
(map_goal_and_eval_terms (monomorphic_term ctxt insts T) (check_goal, eval_terms)) handle WELLSORTED s => (SOME T, Wellsorted_Error s)) (default_insts ctxt) else [(NONE, Term (preprocess ctxt check_goal, eval_terms))]) goals val error_msg =
cat_lines
(maps (map_filter (fn (_, Term _) => NONE | (_, Wellsorted_Error s) => SOME s)) inst_goals) fun is_wellsorted_term (T, Term t) = SOME (T, t)
| is_wellsorted_term (_, Wellsorted_Error _) = NONE val correct_inst_goals =
(casemap (map_filter is_wellsorted_term) inst_goals of
[[]] => error error_msg
| xs => xs) val _ = if Config.get ctxt Quickcheck.quiet then () else warning error_msg in correct_inst_goals end
(* compilation of testing functions *)
fun mk_safe_if genuine_only none (cond, then_t, else_t) genuine = let val T = fastype_of then_t val if_t = Const (\<^const_name>\<open>If\<close>, \<^typ>\<open>bool\<close> --> T --> T --> T) in Const (\<^const_name>\<open>Quickcheck_Random.catch_match\<close>, T --> T --> T) $
(if_t $ cond $ then_t $ else_t genuine) $
(if_t $ genuine_only $ none $ else_t false) end
fun collect_results _ [] results = results
| collect_results f (t :: ts) results = letval result = f t in if Quickcheck.found_counterexample result then result :: results else collect_results f ts (result :: results) end
fun generator_test_goal_terms generator ctxt catch_code_errors insts goals = let val use_subtype = Config.get ctxt Quickcheck.use_subtype fun add_eval_term t ts = if is_Free t then ts else ts @ [t] fun add_equation_eval_terms (t, eval_terms) =
(casetry HOLogic.dest_eq (snd (strip_imp t)) of
SOME (lhs, rhs) => (t, add_eval_term lhs (add_eval_term rhs eval_terms))
| NONE => (t, eval_terms)) fun test_term' goal =
(case goal of
[(NONE, t)] => test_term generator ctxt catch_code_errors t
| ts => test_term_with_cardinality generator ctxt catch_code_errors (map snd ts)) val goals' =
instantiate_goals ctxt insts goals
|> (if use_subtype thenmap (map (subtype_preprocess ctxt)) else I)
|> map (map (apsnd add_equation_eval_terms)) in if Config.get ctxt Quickcheck.finite_types then
collect_results test_term' goals' [] else collect_results (test_term generator ctxt catch_code_errors) (maps (map snd) goals') [] end
(* defining functions *)
fun pat_completeness_auto ctxt =
Pat_Completeness.pat_completeness_tac ctxt 1 THEN auto_tac ctxt
fun define_functions (mk_equations, termination_tac) prfx argnames names Ts = if define_foundationally andalso is_some termination_tac then let val eqs_t = mk_equations (map2 (fn name => fn T => Free (name, T)) names Ts) in
Function.add_function
(map (fn (name, T) => (Binding.concealed (Binding.name name), SOME T, NoSyn))
(names ~~ Ts))
(map (fn t => (((Binding.concealed Binding.empty, []), t), [], [])) eqs_t)
Function_Common.default_config pat_completeness_auto
#> snd
#> (fn lthy => Function.prove_termination NONE (the termination_tac lthy) lthy)
#> snd end else
fold_map (fn (name, T) => Local_Theory.define
((Binding.concealed (Binding.name name), NoSyn),
(apfst Binding.concealed Binding.empty_atts, mk_undefined T))
#> apfst fst) (names ~~ Ts)
#> (fn (consts, lthy) => let val eqs_t = mk_equations consts val eqs = map (fn eq => Goal.prove lthy argnames [] eq
(fn {context = ctxt, ...} => ALLGOALS (Skip_Proof.cheat_tac ctxt))) eqs_t in
lthy
|> fold_map (fn (name, eq) => Local_Theory.note
(((Binding.qualify true prfx o Binding.qualify true name) (Binding.name "simps"), []), [eq]))
(names ~~ eqs)
|-> (fn notes => Code.declare_default_eqns (map (rpair true) (maps snd notes))) end)
(** ensuring sort constraints **)
type instantiation =
Old_Datatype_Aux.config -> Old_Datatype_Aux.descr -> (string * sort) list -> stringlist -> string -> stringlist * stringlist -> typ list * typ list -> theory -> theory
fun perhaps_constrain thy insts raw_vs = let fun meet (T, sort) = Sorts.meet_sort (Sign.classes_of thy) (Logic.varifyT_global T, sort) val vtab = Vartab.empty
|> fold (fn (v, sort) => Vartab.update ((v, 0), sort)) raw_vs
|> fold meet insts in SOME (fn (v, _) => (v, (the o Vartab.lookup vtab) (v, 0))) end handle Sorts.CLASS_ERROR _ => NONE
fun ensure_sort (((sort_vs, aux_sort), sort), (the_descr, instantiate)) config raw_tycos thy =
(casetry (the_descr thy) raw_tycos of
NONE => thy
| SOME (descr, raw_vs, tycos, prfx, (names, auxnames), raw_TUs) => let val algebra = Sign.classes_of thy val vs = (map o apsnd) (curry (Sorts.inter_sort algebra) sort_vs) raw_vs fun insts_of sort constr = (map (rpair sort) o flat o maps snd o maps snd)
(Old_Datatype_Aux.interpret_construction descr vs constr) val insts = insts_of sort { atyp = single, dtyp = (K o K o K) [] }
@ insts_of aux_sort { atyp = K [], dtyp = K o K } val has_inst = exists (fn tyco => Sorts.has_instance algebra tyco sort) tycos in if has_inst then thy else
(case perhaps_constrain thy insts vs of
SOME constrain =>
instantiate config descr
(map constrain vs) tycos prfx (names, auxnames)
((apply2 o map o map_atyps) (fn TFree v => TFree (constrain v)) raw_TUs) thy
| NONE => thy) end)
fun datatype_interpretation name =
BNF_LFP_Compat.interpretation name compat_prefs o ensure_common_sort_datatype
(** generic parametric compilation **)
fun gen_mk_parametric_generator_expr ((mk_generator_expr, out_of_bounds), T) ctxt ts = let val if_t = Const (\<^const_name>\<open>If\<close>, \<^typ>\<open>bool\<close> --> T --> T --> T) fun mk_if (index, (t, eval_terms)) else_t =
if_t $ (HOLogic.eq_const \<^typ>\<open>natural\<close> $ Bound 0 $ HOLogic.mk_number \<^typ>\<open>natural\<close> index) $
(mk_generator_expr ctxt (t, eval_terms)) $ else_t in absdummy \<^typ>\<open>natural\<close> (fold_rev mk_if (1 upto (length ts) ~~ ts) out_of_bounds) end
(** post-processing of function terms **)
fun dest_fun_upd (Const (\<^const_name>\<open>fun_upd\<close>, _) $ t0 $ t1 $ t2) = (t0, (t1, t2))
| dest_fun_upd t = raise TERM ("dest_fun_upd", [t])
fun mk_fun_upd T1 T2 (t1, t2) t = Const (\<^const_name>\<open>fun_upd\<close>, (T1 --> T2) --> T1 --> T2 --> T1 --> T2) $ t $ t1 $ t2
fun dest_fun_upds t =
(casetry dest_fun_upd t of
NONE =>
(case t of
Abs (_, _, _) => ([], t)
| _ => raise TERM ("dest_fun_upds", [t]))
| SOME (t0, (t1, t2)) => apfst (cons (t1, t2)) (dest_fun_upds t0))
fun make_fun_upds T1 T2 (tps, t) = fold_rev (mk_fun_upd T1 T2) tps t
fun make_coset T [] = Const (\<^const_abbrev>\<open>UNIV\<close>, T --> \<^typ>\<open>bool\<close>)
| make_coset T tps = let val U = T --> \<^typ>\<open>bool\<close> fun invert \<^Const_>\<open>False\<close> = \<^Const>\<open>True\<close>
| invert \<^Const_>\<open>True\<close> = \<^Const>\<open>False\<close> in Const (\<^const_name>\<open>Groups.minus_class.minus\<close>, U --> U --> U) $ Const (\<^const_abbrev>\<open>UNIV\<close>, U) $ make_set T (map (apsnd invert) tps) end
Die Informationen auf dieser Webseite wurden
nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit,
noch Qualität der bereit gestellten Informationen zugesichert.
Bemerkung:
Die farbliche Syntaxdarstellung ist noch experimentell.