src/HOL/Tools/quickcheck_generators.ML
author haftmann
Wed Dec 08 13:34:50 2010 +0100 (2010-12-08)
changeset 41075 4bed56dc95fb
parent 40911 7febf76e0a69
child 41472 f6ab14e61604
permissions -rw-r--r--
primitive definitions of bot/top/inf/sup for bool and fun are named with canonical suffix `_def` rather than `_eq`
     1 (*  Title:      HOL/Tools/quickcheck_generators.ML
     2     Author:     Florian Haftmann, TU Muenchen
     3 
     4 Quickcheck generators for various types.
     5 *)
     6 
     7 signature QUICKCHECK_GENERATORS =
     8 sig
     9   type seed = Random_Engine.seed
    10   val random_fun: typ -> typ -> ('a -> 'a -> bool) -> ('a -> term)
    11     -> (seed -> ('b * (unit -> term)) * seed) -> (seed -> seed * seed)
    12     -> seed -> (('a -> 'b) * (unit -> term)) * seed
    13   val perhaps_constrain: theory -> (typ * sort) list -> (string * sort) list
    14     -> (string * sort -> string * sort) option
    15   val ensure_sort_datatype:
    16     sort * (Datatype.config -> Datatype.descr -> (string * sort) list -> string list -> string ->
    17       string list * string list -> typ list * typ list -> theory -> theory)
    18     -> Datatype.config -> string list -> theory -> theory
    19   val compile_generator_expr:
    20     Proof.context -> term -> int -> term list option * Quickcheck.report option
    21   val put_counterexample: (unit -> int -> seed -> term list option * seed)
    22     -> Proof.context -> Proof.context
    23   val put_counterexample_report: (unit -> int -> seed -> (term list option * (bool list * bool)) * seed)
    24     -> Proof.context -> Proof.context
    25   val setup: theory -> theory
    26 end;
    27 
    28 structure Quickcheck_Generators : QUICKCHECK_GENERATORS =
    29 struct
    30 
    31 (** abstract syntax **)
    32 
    33 fun termifyT T = HOLogic.mk_prodT (T, @{typ "unit => term"})
    34 val size = @{term "i::code_numeral"};
    35 val size_pred = @{term "(i::code_numeral) - 1"};
    36 val size' = @{term "j::code_numeral"};
    37 val seed = @{term "s::Random.seed"};
    38 
    39 
    40 (** typ "'a => 'b" **)
    41 
    42 type seed = Random_Engine.seed;
    43 
    44 fun random_fun T1 T2 eq term_of random random_split seed =
    45   let
    46     val fun_upd = Const (@{const_name fun_upd},
    47       (T1 --> T2) --> T1 --> T2 --> T1 --> T2);
    48     val ((y, t2), seed') = random seed;
    49     val (seed'', seed''') = random_split seed';
    50 
    51     val state = Unsynchronized.ref (seed'', [], fn () => Abs ("x", T1, t2 ()));
    52     fun random_fun' x =
    53       let
    54         val (seed, fun_map, f_t) = ! state;
    55       in case AList.lookup (uncurry eq) fun_map x
    56        of SOME y => y
    57         | NONE => let
    58               val t1 = term_of x;
    59               val ((y, t2), seed') = random seed;
    60               val fun_map' = (x, y) :: fun_map;
    61               val f_t' = fn () => fun_upd $ f_t () $ t1 $ t2 ();
    62               val _ = state := (seed', fun_map', f_t');
    63             in y end
    64       end;
    65     fun term_fun' () = #3 (! state) ();
    66   in ((random_fun', term_fun'), seed''') end;
    67 
    68 
    69 (** datatypes **)
    70 
    71 (* definitional scheme for random instances on datatypes *)
    72 
    73 local
    74 
    75 fun dest_ctyp_nth k cT = nth (Thm.dest_ctyp cT) k;
    76 val eq = Thm.cprop_of @{thm random_aux_rec} |> Thm.dest_arg |> Thm.dest_arg |> Thm.dest_arg;
    77 val lhs = eq |> Thm.dest_arg1;
    78 val pt_random_aux = lhs |> Thm.dest_fun;
    79 val ct_k = lhs |> Thm.dest_arg;
    80 val pt_rhs = eq |> Thm.dest_arg |> Thm.dest_fun;
    81 val aT = pt_random_aux |> Thm.ctyp_of_term |> dest_ctyp_nth 1;
    82 
    83 val rew_thms = map mk_meta_eq [@{thm code_numeral_zero_minus_one},
    84   @{thm Suc_code_numeral_minus_one}, @{thm select_weight_cons_zero}, @{thm beyond_zero}];
    85 val rew_ts = map (Logic.dest_equals o Thm.prop_of) rew_thms;
    86 val rew_ss = HOL_ss addsimps rew_thms;
    87 
    88 in
    89 
    90 fun random_aux_primrec eq lthy =
    91   let
    92     val thy = ProofContext.theory_of lthy;
    93     val ((t_random_aux as Free (random_aux, T)) $ (t_k as Free (v, _)), proto_t_rhs) =
    94       (HOLogic.dest_eq o HOLogic.dest_Trueprop) eq;
    95     val Type (_, [_, iT]) = T;
    96     val icT = Thm.ctyp_of thy iT;
    97     val cert = Thm.cterm_of thy;
    98     val inst = Thm.instantiate_cterm ([(aT, icT)], []);
    99     fun subst_v t' = map_aterms (fn t as Free (w, _) => if v = w then t' else t | t => t);
   100     val t_rhs = lambda t_k proto_t_rhs;
   101     val eqs0 = [subst_v @{term "0::code_numeral"} eq,
   102       subst_v (@{term "Suc_code_numeral"} $ t_k) eq];
   103     val eqs1 = map (Pattern.rewrite_term thy rew_ts []) eqs0;
   104     val ((_, (_, eqs2)), lthy') = Primrec.add_primrec_simple
   105       [((Binding.conceal (Binding.name random_aux), T), NoSyn)] eqs1 lthy;
   106     val cT_random_aux = inst pt_random_aux;
   107     val cT_rhs = inst pt_rhs;
   108     val rule = @{thm random_aux_rec}
   109       |> Drule.instantiate ([(aT, icT)],
   110            [(cT_random_aux, cert t_random_aux), (cT_rhs, cert t_rhs)]);
   111     val tac = ALLGOALS (rtac rule)
   112       THEN ALLGOALS (simp_tac rew_ss)
   113       THEN (ALLGOALS (ProofContext.fact_tac eqs2))
   114     val simp = Skip_Proof.prove lthy' [v] [] eq (K tac);
   115   in (simp, lthy') end;
   116 
   117 end;
   118 
   119 fun random_aux_primrec_multi auxname [eq] lthy =
   120       lthy
   121       |> random_aux_primrec eq
   122       |>> (fn simp => [simp])
   123   | random_aux_primrec_multi auxname (eqs as _ :: _ :: _) lthy =
   124       let
   125         val thy = ProofContext.theory_of lthy;
   126         val (lhss, rhss) = map_split (HOLogic.dest_eq o HOLogic.dest_Trueprop) eqs;
   127         val (vs, (arg as Free (v, _)) :: _) = map_split (fn (t1 $ t2) => (t1, t2)) lhss;
   128         val Ts = map fastype_of lhss;
   129         val tupleT = foldr1 HOLogic.mk_prodT Ts;
   130         val aux_lhs = Free ("mutual_" ^ auxname, fastype_of arg --> tupleT) $ arg;
   131         val aux_eq = (HOLogic.mk_Trueprop o HOLogic.mk_eq)
   132           (aux_lhs, foldr1 HOLogic.mk_prod rhss);
   133         fun mk_proj t [T] = [t]
   134           | mk_proj t (Ts as T :: (Ts' as _ :: _)) =
   135               Const (@{const_name fst}, foldr1 HOLogic.mk_prodT Ts --> T) $ t
   136                 :: mk_proj (Const (@{const_name snd},
   137                   foldr1 HOLogic.mk_prodT Ts --> foldr1 HOLogic.mk_prodT Ts') $ t) Ts';
   138         val projs = mk_proj (aux_lhs) Ts;
   139         val proj_eqs = map2 (fn v => fn proj => (v, lambda arg proj)) vs projs;
   140         val proj_defs = map2 (fn Free (name, _) => fn (_, rhs) =>
   141           ((Binding.conceal (Binding.name name), NoSyn),
   142             (apfst Binding.conceal Attrib.empty_binding, rhs))) vs proj_eqs;
   143         val aux_eq' = Pattern.rewrite_term thy proj_eqs [] aux_eq;
   144         fun prove_eqs aux_simp proj_defs lthy = 
   145           let
   146             val proj_simps = map (snd o snd) proj_defs;
   147             fun tac { context = ctxt, prems = _ } =
   148               ALLGOALS (simp_tac (HOL_ss addsimps proj_simps))
   149               THEN ALLGOALS (EqSubst.eqsubst_tac ctxt [0] [aux_simp])
   150               THEN ALLGOALS (simp_tac (HOL_ss addsimps [@{thm fst_conv}, @{thm snd_conv}]));
   151           in (map (fn prop => Skip_Proof.prove lthy [v] [] prop tac) eqs, lthy) end;
   152       in
   153         lthy
   154         |> random_aux_primrec aux_eq'
   155         ||>> fold_map Local_Theory.define proj_defs
   156         |-> (fn (aux_simp, proj_defs) => prove_eqs aux_simp proj_defs)
   157       end;
   158 
   159 fun random_aux_specification prfx name eqs lthy =
   160   let
   161     val vs = fold Term.add_free_names ((snd o strip_comb o fst o HOLogic.dest_eq
   162       o HOLogic.dest_Trueprop o hd) eqs) [];
   163     fun mk_proto_eq eq =
   164       let
   165         val (head $ t $ u, rhs) = (HOLogic.dest_eq o HOLogic.dest_Trueprop) eq;
   166       in ((HOLogic.mk_Trueprop o HOLogic.mk_eq) (head, lambda t (lambda u rhs))) end;
   167     val proto_eqs = map mk_proto_eq eqs;
   168     fun prove_simps proto_simps lthy =
   169       let
   170         val ext_simps = map (fn thm => fun_cong OF [fun_cong OF [thm]]) proto_simps;
   171         val tac = ALLGOALS (ProofContext.fact_tac ext_simps);
   172       in (map (fn prop => Skip_Proof.prove lthy vs [] prop (K tac)) eqs, lthy) end;
   173     val b = Binding.conceal (Binding.qualify true prfx
   174       (Binding.qualify true name (Binding.name "simps")));
   175   in
   176     lthy
   177     |> random_aux_primrec_multi (name ^ prfx) proto_eqs
   178     |-> (fn proto_simps => prove_simps proto_simps)
   179     |-> (fn simps => Local_Theory.note
   180       ((b, Code.add_default_eqn_attrib :: map (Attrib.internal o K)
   181           [Simplifier.simp_add, Nitpick_Simps.add]), simps))
   182     |> snd
   183   end
   184 
   185 
   186 (* constructing random instances on datatypes *)
   187 
   188 val random_auxN = "random_aux";
   189 
   190 fun mk_random_aux_eqs thy descr vs tycos (names, auxnames) (Ts, Us) =
   191   let
   192     val mk_const = curry (Sign.mk_const thy);
   193     val random_auxsN = map (prefix (random_auxN ^ "_")) (names @ auxnames);
   194     val rTs = Ts @ Us;
   195     fun random_resultT T = @{typ Random.seed}
   196       --> HOLogic.mk_prodT (termifyT T,@{typ Random.seed});
   197     val pTs = map random_resultT rTs;
   198     fun sizeT T = @{typ code_numeral} --> @{typ code_numeral} --> T;
   199     val random_auxT = sizeT o random_resultT;
   200     val random_auxs = map2 (fn s => fn rT => Free (s, random_auxT rT))
   201       random_auxsN rTs;
   202     fun mk_random_call T = (NONE, (HOLogic.mk_random T size', T));
   203     fun mk_random_aux_call fTs (k, _) (tyco, Ts) =
   204       let
   205         val T = Type (tyco, Ts);
   206         fun mk_random_fun_lift [] t = t
   207           | mk_random_fun_lift (fT :: fTs) t =
   208               mk_const @{const_name random_fun_lift} [fTs ---> T, fT] $
   209                 mk_random_fun_lift fTs t;
   210         val t = mk_random_fun_lift fTs (nth random_auxs k $ size_pred $ size');
   211         val size = Option.map snd (Datatype_Aux.find_shortest_path descr k)
   212           |> the_default 0;
   213       in (SOME size, (t, fTs ---> T)) end;
   214     val tss = Datatype_Aux.interpret_construction descr vs
   215       { atyp = mk_random_call, dtyp = mk_random_aux_call };
   216     fun mk_consexpr simpleT (c, xs) =
   217       let
   218         val (ks, simple_tTs) = split_list xs;
   219         val T = termifyT simpleT;
   220         val tTs = (map o apsnd) termifyT simple_tTs;
   221         val is_rec = exists is_some ks;
   222         val k = fold (fn NONE => I | SOME k => Integer.max k) ks 0;
   223         val vs = Name.names Name.context "x" (map snd simple_tTs);
   224         val tc = HOLogic.mk_return T @{typ Random.seed}
   225           (HOLogic.mk_valtermify_app c vs simpleT);
   226         val t = HOLogic.mk_ST
   227           (map2 (fn (t, _) => fn (v, T') => ((t, @{typ Random.seed}), SOME ((v, termifyT T')))) tTs vs)
   228             tc @{typ Random.seed} (SOME T, @{typ Random.seed});
   229         val tk = if is_rec
   230           then if k = 0 then size
   231             else @{term "Quickcheck.beyond :: code_numeral \<Rightarrow> code_numeral \<Rightarrow> code_numeral"}
   232              $ HOLogic.mk_number @{typ code_numeral} k $ size
   233           else @{term "1::code_numeral"}
   234       in (is_rec, HOLogic.mk_prod (tk, t)) end;
   235     fun sort_rec xs =
   236       map_filter (fn (true, t) => SOME t | _ =>  NONE) xs
   237       @ map_filter (fn (false, t) => SOME t | _ =>  NONE) xs;
   238     val gen_exprss = tss
   239       |> (map o apfst) Type
   240       |> map (fn (T, cs) => (T, (sort_rec o map (mk_consexpr T)) cs));
   241     fun mk_select (rT, xs) =
   242       mk_const @{const_name Quickcheck.collapse} [@{typ "Random.seed"}, termifyT rT]
   243       $ (mk_const @{const_name Random.select_weight} [random_resultT rT]
   244         $ HOLogic.mk_list (HOLogic.mk_prodT (@{typ code_numeral}, random_resultT rT)) xs)
   245           $ seed;
   246     val auxs_lhss = map (fn t => t $ size $ size' $ seed) random_auxs;
   247     val auxs_rhss = map mk_select gen_exprss;
   248   in (random_auxs, auxs_lhss ~~ auxs_rhss) end;
   249 
   250 fun instantiate_random_datatype config descr vs tycos prfx (names, auxnames) (Ts, Us) thy =
   251   let
   252     val _ = Datatype_Aux.message config "Creating quickcheck generators ...";
   253     val mk_prop_eq = HOLogic.mk_Trueprop o HOLogic.mk_eq;
   254     fun mk_size_arg k = case Datatype_Aux.find_shortest_path descr k
   255      of SOME (_, l) => if l = 0 then size
   256           else @{term "max :: code_numeral \<Rightarrow> code_numeral \<Rightarrow> code_numeral"}
   257             $ HOLogic.mk_number @{typ code_numeral} l $ size
   258       | NONE => size;
   259     val (random_auxs, auxs_eqs) = (apsnd o map) mk_prop_eq
   260       (mk_random_aux_eqs thy descr vs tycos (names, auxnames) (Ts, Us));
   261     val random_defs = map_index (fn (k, T) => mk_prop_eq
   262       (HOLogic.mk_random T size, nth random_auxs k $ mk_size_arg k $ size)) Ts;
   263   in
   264     thy
   265     |> Class.instantiation (tycos, vs, @{sort random})
   266     |> random_aux_specification prfx random_auxN auxs_eqs
   267     |> `(fn lthy => map (Syntax.check_term lthy) random_defs)
   268     |-> (fn random_defs' => fold_map (fn random_def =>
   269           Specification.definition (NONE, (apfst Binding.conceal
   270             Attrib.empty_binding, random_def))) random_defs')
   271     |> snd
   272     |> Class.prove_instantiation_exit (K (Class.intro_classes_tac []))
   273   end;
   274 
   275 fun perhaps_constrain thy insts raw_vs =
   276   let
   277     fun meet (T, sort) = Sorts.meet_sort (Sign.classes_of thy) 
   278       (Logic.varifyT_global T, sort);
   279     val vtab = Vartab.empty
   280       |> fold (fn (v, sort) => Vartab.update ((v, 0), sort)) raw_vs
   281       |> fold meet insts;
   282   in SOME (fn (v, _) => (v, (the o Vartab.lookup vtab) (v, 0)))
   283   end handle Sorts.CLASS_ERROR _ => NONE;
   284 
   285 fun ensure_sort_datatype (sort, instantiate_datatype) config raw_tycos thy =
   286   let
   287     val algebra = Sign.classes_of thy;
   288     val (descr, raw_vs, tycos, prfx, (names, auxnames), raw_TUs) =
   289       Datatype.the_descr thy raw_tycos;
   290     val typerep_vs = (map o apsnd)
   291       (curry (Sorts.inter_sort algebra) @{sort typerep}) raw_vs;
   292     val sort_insts = (map (rpair sort) o flat o maps snd o maps snd)
   293       (Datatype_Aux.interpret_construction descr typerep_vs
   294         { atyp = single, dtyp = (K o K o K) [] });
   295     val term_of_insts = (map (rpair @{sort term_of}) o flat o maps snd o maps snd)
   296       (Datatype_Aux.interpret_construction descr typerep_vs
   297         { atyp = K [], dtyp = K o K });
   298     val has_inst = exists (fn tyco =>
   299       can (Sorts.mg_domain algebra tyco) sort) tycos;
   300   in if has_inst then thy
   301     else case perhaps_constrain thy (sort_insts @ term_of_insts) typerep_vs
   302      of SOME constrain => instantiate_datatype config descr
   303           (map constrain typerep_vs) tycos prfx (names, auxnames)
   304             ((pairself o map o map_atyps) (fn TFree v => TFree (constrain v)) raw_TUs) thy
   305       | NONE => thy
   306   end;
   307 
   308 (** building and compiling generator expressions **)
   309 
   310 structure Counterexample = Proof_Data (
   311   type T = unit -> int -> int * int -> term list option * (int * int)
   312   fun init _ () = error "Counterexample"
   313 );
   314 val put_counterexample = Counterexample.put;
   315 
   316 structure Counterexample_Report = Proof_Data (
   317   type T = unit -> int -> seed -> (term list option * (bool list * bool)) * seed
   318   fun init _ () = error "Counterexample_Report"
   319 );
   320 val put_counterexample_report = Counterexample_Report.put;
   321 
   322 val target = "Quickcheck";
   323 
   324 fun mk_generator_expr thy prop Ts =
   325   let
   326     val bound_max = length Ts - 1;
   327     val bounds = map_index (fn (i, ty) =>
   328       (2 * (bound_max - i) + 1, 2 * (bound_max - i), 2 * i, ty)) Ts;
   329     val result = list_comb (prop, map (fn (i, _, _, _) => Bound i) bounds);
   330     val terms = HOLogic.mk_list @{typ term} (map (fn (_, i, _, _) => Bound i $ @{term "()"}) bounds);
   331     val check = @{term "If :: bool => term list option => term list option => term list option"}
   332       $ result $ @{term "None :: term list option"} $ (@{term "Some :: term list => term list option"} $ terms);
   333     val return = @{term "Pair :: term list option => Random.seed => term list option * Random.seed"};
   334     fun liftT T sT = sT --> HOLogic.mk_prodT (T, sT);
   335     fun mk_termtyp T = HOLogic.mk_prodT (T, @{typ "unit => term"});
   336     fun mk_scomp T1 T2 sT f g = Const (@{const_name scomp},
   337       liftT T1 sT --> (T1 --> liftT T2 sT) --> liftT T2 sT) $ f $ g;
   338     fun mk_split T = Sign.mk_const thy
   339       (@{const_name prod_case}, [T, @{typ "unit => term"}, liftT @{typ "term list option"} @{typ Random.seed}]);
   340     fun mk_scomp_split T t t' =
   341       mk_scomp (mk_termtyp T) @{typ "term list option"} @{typ Random.seed} t
   342         (mk_split T $ Abs ("", T, Abs ("", @{typ "unit => term"}, t')));
   343     fun mk_bindclause (_, _, i, T) = mk_scomp_split T
   344       (Sign.mk_const thy (@{const_name Quickcheck.random}, [T]) $ Bound i);
   345   in Abs ("n", @{typ code_numeral}, fold_rev mk_bindclause bounds (return $ check)) end;
   346 
   347 fun mk_reporting_generator_expr thy prop Ts =
   348   let
   349     val bound_max = length Ts - 1;
   350     val bounds = map_index (fn (i, ty) =>
   351       (2 * (bound_max - i) + 1, 2 * (bound_max - i), 2 * i, ty)) Ts;
   352     fun strip_imp (Const(@{const_name HOL.implies},_) $ A $ B) = apfst (cons A) (strip_imp B)
   353       | strip_imp A = ([], A)
   354     val prop' = betapplys (prop, map (fn (i, _, _, _) => Bound i) bounds);
   355     val terms = HOLogic.mk_list @{typ term} (map (fn (_, i, _, _) => Bound i $ @{term "()"}) bounds)
   356     val (assms, concl) = strip_imp prop'
   357     val return =
   358       @{term "Pair :: term list option * (bool list * bool) => Random.seed => (term list option * (bool list * bool)) * Random.seed"};
   359     fun mk_assms_report i =
   360       HOLogic.mk_prod (@{term "None :: term list option"},
   361         HOLogic.mk_prod (HOLogic.mk_list HOLogic.boolT
   362           (replicate i @{term True} @ replicate (length assms - i) @{term False}),
   363         @{term False}))
   364     fun mk_concl_report b =
   365       HOLogic.mk_prod (HOLogic.mk_list HOLogic.boolT (replicate (length assms) @{term True}),
   366         if b then @{term True} else @{term False})
   367     val If =
   368       @{term "If :: bool => term list option * (bool list * bool) => term list option * (bool list * bool) => term list option * (bool list * bool)"}
   369     val concl_check = If $ concl $
   370       HOLogic.mk_prod (@{term "None :: term list option"}, mk_concl_report true) $
   371       HOLogic.mk_prod (@{term "Some :: term list  => term list option"} $ terms, mk_concl_report false)
   372     val check = fold_rev (fn (i, assm) => fn t => If $ assm $ t $ mk_assms_report i)
   373       (map_index I assms) concl_check
   374     fun liftT T sT = sT --> HOLogic.mk_prodT (T, sT);
   375     fun mk_termtyp T = HOLogic.mk_prodT (T, @{typ "unit => term"});
   376     fun mk_scomp T1 T2 sT f g = Const (@{const_name scomp},
   377       liftT T1 sT --> (T1 --> liftT T2 sT) --> liftT T2 sT) $ f $ g;
   378     fun mk_split T = Sign.mk_const thy
   379       (@{const_name prod_case}, [T, @{typ "unit => term"},
   380         liftT @{typ "term list option * (bool list * bool)"} @{typ Random.seed}]);
   381     fun mk_scomp_split T t t' =
   382       mk_scomp (mk_termtyp T) @{typ "term list option * (bool list * bool)"} @{typ Random.seed} t
   383         (mk_split T $ Abs ("", T, Abs ("", @{typ "unit => term"}, t')));
   384     fun mk_bindclause (_, _, i, T) = mk_scomp_split T
   385       (Sign.mk_const thy (@{const_name Quickcheck.random}, [T]) $ Bound i);
   386   in
   387     Abs ("n", @{typ code_numeral}, fold_rev mk_bindclause bounds (return $ check))
   388   end
   389 
   390 (* single quickcheck report *)
   391 
   392 datatype single_report = Run of bool list * bool | MatchExc
   393 
   394 fun collect_single_report single_report
   395     (Quickcheck.Report {iterations = iterations, raised_match_errors = raised_match_errors,
   396     satisfied_assms = satisfied_assms, positive_concl_tests = positive_concl_tests}) =
   397   case single_report
   398   of MatchExc =>
   399     Quickcheck.Report {iterations = iterations + 1, raised_match_errors = raised_match_errors + 1,
   400       satisfied_assms = satisfied_assms, positive_concl_tests = positive_concl_tests}
   401    | Run (assms, concl) =>
   402     Quickcheck.Report {iterations = iterations + 1, raised_match_errors = raised_match_errors,
   403       satisfied_assms =
   404         map2 (fn b => fn s => if b then s + 1 else s) assms
   405          (if null satisfied_assms then replicate (length assms) 0 else satisfied_assms),
   406       positive_concl_tests = if concl then positive_concl_tests + 1 else positive_concl_tests}
   407 
   408 val empty_report = Quickcheck.Report { iterations = 0, raised_match_errors = 0,
   409   satisfied_assms = [], positive_concl_tests = 0 }
   410     
   411 fun compile_generator_expr ctxt t =
   412   let
   413     val Ts = (map snd o fst o strip_abs) t;
   414     val thy = ProofContext.theory_of ctxt
   415     val iterations = Config.get ctxt Quickcheck.iterations
   416   in
   417     if Config.get ctxt Quickcheck.report then
   418       let
   419         val t' = mk_reporting_generator_expr thy t Ts;
   420         val compile = Code_Runtime.dynamic_value_strict
   421           (Counterexample_Report.get, put_counterexample_report, "Quickcheck_Generators.put_counterexample_report")
   422           thy (SOME target) (fn proc => fn g => fn s => g s #>> (apfst o Option.map o map) proc) t' [];
   423         val single_tester = compile #> Random_Engine.run
   424         fun iterate_and_collect size 0 report = (NONE, report)
   425           | iterate_and_collect size j report =
   426             let
   427               val (test_result, single_report) = apsnd Run (single_tester size) handle Match => 
   428                 (if Config.get ctxt Quickcheck.quiet then ()
   429                  else warning "Exception Match raised during quickcheck"; (NONE, MatchExc))
   430               val report = collect_single_report single_report report
   431             in
   432               case test_result of NONE => iterate_and_collect size (j - 1) report
   433                 | SOME q => (SOME q, report)
   434             end
   435       in
   436         fn size => apsnd SOME (iterate_and_collect size iterations empty_report)
   437       end
   438     else
   439       let
   440         val t' = mk_generator_expr thy t Ts;
   441         val compile = Code_Runtime.dynamic_value_strict
   442           (Counterexample.get, put_counterexample, "Quickcheck_Generators.put_counterexample")
   443           thy (SOME target) (fn proc => fn g => fn s => g s #>> (Option.map o map) proc) t' [];
   444         val single_tester = compile #> Random_Engine.run
   445         fun iterate size 0 = NONE
   446           | iterate size j =
   447             let
   448               val result = single_tester size handle Match => 
   449                 (if Config.get ctxt Quickcheck.quiet then ()
   450                  else warning "Exception Match raised during quickcheck"; NONE)
   451             in
   452               case result of NONE => iterate size (j - 1) | SOME q => SOME q
   453             end
   454       in
   455         fn size => (rpair NONE (iterate size iterations))
   456       end
   457   end;
   458 
   459 
   460 (** setup **)
   461 
   462 val setup =
   463   Datatype.interpretation (ensure_sort_datatype (@{sort random}, instantiate_random_datatype))
   464   #> Code_Target.extend_target (target, (Code_Runtime.target, K I))
   465   #> Context.theory_map
   466     (Quickcheck.add_generator ("random", compile_generator_expr));
   467 
   468 end;