src/HOL/Tools/Predicate_Compile/predicate_compile_quickcheck.ML
changeset 69593 3dda49e08b9d
parent 61140 78ece168f5b5
equal deleted inserted replaced
69592:a80d8ec6c998 69593:3dda49e08b9d
   219     val t' = fold_rev absfree (Term.add_frees t []) t
   219     val t' = fold_rev absfree (Term.add_frees t []) t
   220     val thy = Proof_Context.theory_of ctxt
   220     val thy = Proof_Context.theory_of ctxt
   221     val ((((full_constname, constT), vs'), intro), thy1) =
   221     val ((((full_constname, constT), vs'), intro), thy1) =
   222       Predicate_Compile_Aux.define_quickcheck_predicate t' thy
   222       Predicate_Compile_Aux.define_quickcheck_predicate t' thy
   223     val thy2 =
   223     val thy2 =
   224       Context.theory_map (Named_Theorems.add_thm @{named_theorems code_pred_def} intro) thy1
   224       Context.theory_map (Named_Theorems.add_thm \<^named_theorems>\<open>code_pred_def\<close> intro) thy1
   225     val (thy3, _) = cpu_time "predicate preprocessing"
   225     val (thy3, _) = cpu_time "predicate preprocessing"
   226         (fn () => Predicate_Compile.preprocess options (Const (full_constname, constT)) thy2)
   226         (fn () => Predicate_Compile.preprocess options (Const (full_constname, constT)) thy2)
   227     val (thy4, _) = cpu_time "random_dseq core compilation"
   227     val (thy4, _) = cpu_time "random_dseq core compilation"
   228         (fn () =>
   228         (fn () =>
   229           case compilation of
   229           case compilation of
   249             (case compilation of
   249             (case compilation of
   250               Pos_Random_DSeq => mk_randompredT (HOLogic.mk_tupleT (map snd vs'))
   250               Pos_Random_DSeq => mk_randompredT (HOLogic.mk_tupleT (map snd vs'))
   251             | New_Pos_Random_DSeq => mk_new_randompredT (HOLogic.mk_tupleT (map snd vs'))
   251             | New_Pos_Random_DSeq => mk_new_randompredT (HOLogic.mk_tupleT (map snd vs'))
   252             | Pos_Generator_DSeq => mk_new_dseqT (HOLogic.mk_tupleT (map snd vs'))
   252             | Pos_Generator_DSeq => mk_new_dseqT (HOLogic.mk_tupleT (map snd vs'))
   253             | Depth_Limited_Random =>
   253             | Depth_Limited_Random =>
   254                 [@{typ natural}, @{typ natural}, @{typ natural},
   254                 [\<^typ>\<open>natural\<close>, \<^typ>\<open>natural\<close>, \<^typ>\<open>natural\<close>,
   255                  @{typ Random.seed}] ---> mk_predT (HOLogic.mk_tupleT (map snd vs'))
   255                  \<^typ>\<open>Random.seed\<close>] ---> mk_predT (HOLogic.mk_tupleT (map snd vs'))
   256             | Pos_Generator_CPS => mk_cpsT (HOLogic.mk_tupleT (map snd vs')))
   256             | Pos_Generator_CPS => mk_cpsT (HOLogic.mk_tupleT (map snd vs')))
   257         in
   257         in
   258           Const (name, T)
   258           Const (name, T)
   259         end
   259         end
   260       else error ("Predicate Compile Quickcheck failed: " ^ commas (map string_of_mode modes))
   260       else error ("Predicate Compile Quickcheck failed: " ^ commas (map string_of_mode modes))
   261     fun mk_Some T = Const (@{const_name "Option.Some"}, T --> Type (@{type_name "Option.option"}, [T]))
   261     fun mk_Some T = Const (\<^const_name>\<open>Option.Some\<close>, T --> Type (\<^type_name>\<open>Option.option\<close>, [T]))
   262     val qc_term =
   262     val qc_term =
   263       (case compilation of
   263       (case compilation of
   264         Pos_Random_DSeq => mk_bind (prog,
   264         Pos_Random_DSeq => mk_bind (prog,
   265           mk_split_lambda (map Free vs') (mk_return (HOLogic.mk_list @{typ term}
   265           mk_split_lambda (map Free vs') (mk_return (HOLogic.mk_list \<^typ>\<open>term\<close>
   266           (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
   266           (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
   267       | New_Pos_Random_DSeq => mk_new_bind (prog,
   267       | New_Pos_Random_DSeq => mk_new_bind (prog,
   268           mk_split_lambda (map Free vs') (mk_new_return (HOLogic.mk_list @{typ term}
   268           mk_split_lambda (map Free vs') (mk_new_return (HOLogic.mk_list \<^typ>\<open>term\<close>
   269           (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
   269           (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
   270       | Pos_Generator_DSeq => mk_gen_bind (prog,
   270       | Pos_Generator_DSeq => mk_gen_bind (prog,
   271           mk_split_lambda (map Free vs') (mk_gen_return (HOLogic.mk_list @{typ term}
   271           mk_split_lambda (map Free vs') (mk_gen_return (HOLogic.mk_list \<^typ>\<open>term\<close>
   272           (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
   272           (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))
   273       | Pos_Generator_CPS => prog $
   273       | Pos_Generator_CPS => prog $
   274           mk_split_lambda (map Free vs') (mk_Some @{typ "bool * term list"} $
   274           mk_split_lambda (map Free vs') (mk_Some \<^typ>\<open>bool * term list\<close> $
   275           HOLogic.mk_prod (@{term "True"}, HOLogic.mk_list @{typ term}
   275           HOLogic.mk_prod (\<^term>\<open>True\<close>, HOLogic.mk_list \<^typ>\<open>term\<close>
   276               (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))
   276               (map2 HOLogic.mk_term_of (map snd vs') (map Free vs'))))
   277       | Depth_Limited_Random => fold_rev absdummy
   277       | Depth_Limited_Random => fold_rev absdummy
   278           [@{typ natural}, @{typ natural}, @{typ natural},
   278           [\<^typ>\<open>natural\<close>, \<^typ>\<open>natural\<close>, \<^typ>\<open>natural\<close>,
   279            @{typ Random.seed}]
   279            \<^typ>\<open>Random.seed\<close>]
   280           (mk_bind' (list_comb (prog, map Bound (3 downto 0)),
   280           (mk_bind' (list_comb (prog, map Bound (3 downto 0)),
   281           mk_split_lambda (map Free vs') (mk_return' (HOLogic.mk_list @{typ term}
   281           mk_split_lambda (map Free vs') (mk_return' (HOLogic.mk_list \<^typ>\<open>term\<close>
   282           (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))))
   282           (map2 HOLogic.mk_term_of (map snd vs') (map Free vs')))))))
   283     val prog =
   283     val prog =
   284       case compilation of
   284       case compilation of
   285         Pos_Random_DSeq =>
   285         Pos_Random_DSeq =>
   286           let
   286           let
   411     Quickcheck_Common.collect_results (test_term ctxt)
   411     Quickcheck_Common.collect_results (test_term ctxt)
   412       (maps (map snd) correct_inst_goals) []
   412       (maps (map snd) correct_inst_goals) []
   413   end
   413   end
   414 
   414 
   415 val smart_exhaustive_active =
   415 val smart_exhaustive_active =
   416   Attrib.setup_config_bool @{binding quickcheck_smart_exhaustive_active} (K true)
   416   Attrib.setup_config_bool \<^binding>\<open>quickcheck_smart_exhaustive_active\<close> (K true)
   417 val smart_slow_exhaustive_active =
   417 val smart_slow_exhaustive_active =
   418   Attrib.setup_config_bool @{binding quickcheck_slow_smart_exhaustive_active} (K false)
   418   Attrib.setup_config_bool \<^binding>\<open>quickcheck_slow_smart_exhaustive_active\<close> (K false)
   419 
   419 
   420 val _ =
   420 val _ =
   421   Theory.setup
   421   Theory.setup
   422    (Exhaustive_Generators.setup_exhaustive_datatype_interpretation #>
   422    (Exhaustive_Generators.setup_exhaustive_datatype_interpretation #>
   423     Context.theory_map (Quickcheck.add_tester ("smart_exhaustive",
   423     Context.theory_map (Quickcheck.add_tester ("smart_exhaustive",