src/HOL/Tools/Quickcheck/exhaustive_generators.ML
changeset 57996 ca917ea6969c
parent 56257 589fafcc7cb6
child 58112 8081087096ad
equal deleted inserted replaced
57995:08aa1e2cbec0 57996:ca917ea6969c
   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