196 |
196 |
197 (** instantiating generator classes **) |
197 (** instantiating generator classes **) |
198 |
198 |
199 fun contains_recursive_type_under_function_types xs = |
199 fun contains_recursive_type_under_function_types xs = |
200 exists (fn (_, (_, _, cs)) => cs |> exists (snd #> exists (fn dT => |
200 exists (fn (_, (_, _, cs)) => cs |> exists (snd #> exists (fn dT => |
201 (case Datatype_Aux.strip_dtyp dT of (_ :: _, Datatype.DtRec _) => true | _ => false)))) xs |
201 (case Datatype_Aux.strip_dtyp dT of (_ :: _, Datatype_Aux.DtRec _) => true | _ => false)))) xs |
202 |
202 |
203 fun instantiate_datatype (name, constprfx, sort, mk_equations, mk_T, argnames) |
203 fun instantiate_datatype (name, constprfx, sort, mk_equations, mk_T, argnames) |
204 config descr vs tycos prfx (names, auxnames) (Ts, Us) thy = |
204 config descr vs tycos prfx (names, auxnames) (Ts, Us) thy = |
205 if not (contains_recursive_type_under_function_types descr) then |
205 if not (contains_recursive_type_under_function_types descr) then |
206 let |
206 let |
252 |
252 |
253 fun mk_test_term lookup mk_closure mk_if mk_let none_t return ctxt = |
253 fun mk_test_term lookup mk_closure mk_if mk_let none_t return ctxt = |
254 let |
254 let |
255 val cnstrs = flat (maps |
255 val cnstrs = flat (maps |
256 (map (fn (_, (Tname, _, cs)) => map (apsnd (rpair Tname o length)) cs) o #descr o snd) |
256 (map (fn (_, (Tname, _, cs)) => map (apsnd (rpair Tname o length)) cs) o #descr o snd) |
257 (Symtab.dest (Datatype.get_all (Proof_Context.theory_of ctxt)))) |
257 (Symtab.dest (Datatype_Data.get_all (Proof_Context.theory_of ctxt)))) |
258 fun is_constrt (Const (s, T), ts) = (case (AList.lookup (op =) cnstrs s, body_type T) of |
258 fun is_constrt (Const (s, T), ts) = (case (AList.lookup (op =) cnstrs s, body_type T) of |
259 (SOME (i, Tname), Type (Tname', _)) => length ts = i andalso Tname = Tname' |
259 (SOME (i, Tname), Type (Tname', _)) => length ts = i andalso Tname = Tname' |
260 | _ => false) |
260 | _ => false) |
261 | is_constrt _ = false |
261 | is_constrt _ = false |
262 fun mk_naive_test_term t = |
262 fun mk_naive_test_term t = |
535 |
535 |
536 val setup_exhaustive_datatype_interpretation = |
536 val setup_exhaustive_datatype_interpretation = |
537 Quickcheck_Common.datatype_interpretation (@{sort exhaustive}, instantiate_exhaustive_datatype) |
537 Quickcheck_Common.datatype_interpretation (@{sort exhaustive}, instantiate_exhaustive_datatype) |
538 |
538 |
539 val setup_bounded_forall_datatype_interpretation = |
539 val setup_bounded_forall_datatype_interpretation = |
540 Datatype.interpretation (Quickcheck_Common.ensure_sort |
540 Datatype_Data.interpretation (Quickcheck_Common.ensure_sort |
541 (((@{sort type}, @{sort type}), @{sort bounded_forall}), |
541 (((@{sort type}, @{sort type}), @{sort bounded_forall}), |
542 (Datatype.the_descr, instantiate_bounded_forall_datatype))) |
542 (Datatype_Data.the_descr, instantiate_bounded_forall_datatype))) |
543 |
543 |
544 val active = Attrib.setup_config_bool @{binding quickcheck_exhaustive_active} (K true); |
544 val active = Attrib.setup_config_bool @{binding quickcheck_exhaustive_active} (K true); |
545 |
545 |
546 val setup = |
546 val setup = |
547 Quickcheck_Common.datatype_interpretation (@{sort full_exhaustive}, instantiate_full_exhaustive_datatype) |
547 Quickcheck_Common.datatype_interpretation (@{sort full_exhaustive}, instantiate_full_exhaustive_datatype) |
548 (* #> Datatype.interpretation (Quickcheck_Common.ensure_sort_datatype |
548 (* #> Datatype_Data.interpretation (Quickcheck_Common.ensure_sort_datatype |
549 (((@{sort typerep}, @{sort term_of}), @{sort exhaustive}), instantiate_exhaustive_datatype)) |
549 (((@{sort typerep}, @{sort term_of}), @{sort exhaustive}), instantiate_exhaustive_datatype)) |
550 #> Datatype.interpretation (Quickcheck_Common.ensure_sort_datatype |
550 #> Datatype_Data.interpretation (Quickcheck_Common.ensure_sort_datatype |
551 (((@{sort typerep}, @{sort term_of}), @{sort fast_exhaustive}), instantiate_fast_exhaustive_datatype)) |
551 (((@{sort typerep}, @{sort term_of}), @{sort fast_exhaustive}), instantiate_fast_exhaustive_datatype)) |
552 #> Datatype.interpretation (Quickcheck_Common.ensure_sort_datatype |
552 #> Datatype_Data.interpretation (Quickcheck_Common.ensure_sort_datatype |
553 (((@{sort type}, @{sort type}), @{sort bounded_forall}), instantiate_bounded_forall_datatype))*) |
553 (((@{sort type}, @{sort type}), @{sort bounded_forall}), instantiate_bounded_forall_datatype))*) |
554 #> Context.theory_map (Quickcheck.add_tester ("exhaustive", (active, test_goals))) |
554 #> Context.theory_map (Quickcheck.add_tester ("exhaustive", (active, test_goals))) |
555 #> Context.theory_map (Quickcheck.add_batch_generator ("exhaustive", compile_generator_exprs)) |
555 #> Context.theory_map (Quickcheck.add_batch_generator ("exhaustive", compile_generator_exprs)) |
556 #> Context.theory_map (Quickcheck.add_batch_validator ("exhaustive", compile_validator_exprs)); |
556 #> Context.theory_map (Quickcheck.add_batch_validator ("exhaustive", compile_validator_exprs)); |
557 |
557 |