8 sig |
8 sig |
9 val compile_generator_expr: |
9 val compile_generator_expr: |
10 Proof.context -> term -> int -> term list option * (bool list * bool) |
10 Proof.context -> term -> int -> term list option * (bool list * bool) |
11 val put_counterexample: (unit -> int -> term list option) |
11 val put_counterexample: (unit -> int -> term list option) |
12 -> Proof.context -> Proof.context |
12 -> Proof.context -> Proof.context |
|
13 val smart_quantifier : bool Config.T; |
13 val setup: theory -> theory |
14 val setup: theory -> theory |
14 end; |
15 end; |
15 |
16 |
16 structure Smallvalue_Generators : SMALLVALUE_GENERATORS = |
17 structure Smallvalue_Generators : SMALLVALUE_GENERATORS = |
17 struct |
18 struct |
18 |
19 |
19 (* static options *) |
20 (* static options *) |
20 |
21 |
21 val define_foundationally = false |
22 val define_foundationally = false |
|
23 |
|
24 (* dynamic options *) |
|
25 |
|
26 val (smart_quantifier, setup_smart_quantifier) = |
|
27 Attrib.config_bool "quickcheck_smart_quantifier" (K true) |
22 |
28 |
23 (** general term functions **) |
29 (** general term functions **) |
24 |
30 |
25 fun mk_measure f = |
31 fun mk_measure f = |
26 let |
32 let |
207 ); |
213 ); |
208 val put_counterexample = Counterexample.put; |
214 val put_counterexample = Counterexample.put; |
209 |
215 |
210 val target = "Quickcheck"; |
216 val target = "Quickcheck"; |
211 |
217 |
212 fun mk_generator_expr thy prop Ts = |
218 fun mk_smart_generator_expr ctxt t = |
213 let |
219 let |
|
220 val ((vnames, Ts), t') = apfst split_list (strip_abs t) |
|
221 val ([depth_name], ctxt') = Variable.variant_fixes ["depth"] ctxt |
|
222 val (names, ctxt'') = Variable.variant_fixes vnames ctxt' |
|
223 val (term_names, ctxt''') = Variable.variant_fixes (map (prefix "t_") vnames) ctxt'' |
|
224 val depth = Free (depth_name, @{typ code_numeral}) |
|
225 val frees = map2 (curry Free) names Ts |
|
226 val term_vars = map (fn n => Free (n, @{typ "unit => term"})) term_names |
|
227 fun strip_imp (Const(@{const_name HOL.implies},_) $ A $ B) = apfst (cons A) (strip_imp B) |
|
228 | strip_imp A = ([], A) |
|
229 val (assms, concl) = strip_imp (subst_bounds (rev frees, t')) |
|
230 val terms = HOLogic.mk_list @{typ term} (map (fn v => v $ @{term "()"}) term_vars) |
|
231 fun mk_small_closure (free as Free (_, T), term_var) t = |
|
232 Const (@{const_name "Smallcheck.full_small_class.full_small"}, full_smallT T) |
|
233 $ (HOLogic.split_const (T, @{typ "unit => term"}, @{typ "term list option"}) |
|
234 $ lambda free (lambda term_var t)) $ depth |
|
235 fun lookup v = the (AList.lookup (op =) (names ~~ (frees ~~ term_vars)) v) |
|
236 val none_t = @{term "None :: term list option"} |
|
237 fun mk_safe_if (cond, then_t, else_t) = |
|
238 @{term "Smallcheck.catch_match :: term list option => term list option => term list option"} $ |
|
239 (@{term "If :: bool => term list option => term list option => term list option"} |
|
240 $ cond $ then_t $ else_t) $ none_t; |
|
241 fun mk_test_term bound_vars assms = |
|
242 let |
|
243 fun vars_of t = subtract (op =) bound_vars (Term.add_free_names t []) |
|
244 val (vars, check) = |
|
245 case assms of [] => |
|
246 (vars_of concl, (concl, none_t, @{term "Some :: term list => term list option"} $ terms)) |
|
247 | assm :: assms => |
|
248 (vars_of assm, (assm, mk_test_term (union (op =) (vars_of assm) bound_vars) assms, none_t)) |
|
249 in |
|
250 fold_rev mk_small_closure (map lookup vars) (mk_safe_if check) |
|
251 end |
|
252 in lambda depth (mk_test_term [] assms) end |
|
253 |
|
254 fun mk_generator_expr ctxt t = |
|
255 let |
|
256 val Ts = (map snd o fst o strip_abs) t; |
|
257 val thy = ProofContext.theory_of ctxt |
214 val bound_max = length Ts - 1; |
258 val bound_max = length Ts - 1; |
215 val bounds = map_index (fn (i, ty) => |
259 val bounds = map_index (fn (i, ty) => |
216 (2 * (bound_max - i) + 1, 2 * (bound_max - i), 2 * i, ty)) Ts; |
260 (2 * (bound_max - i) + 1, 2 * (bound_max - i), 2 * i, ty)) Ts; |
217 val result = list_comb (prop, map (fn (i, _, _, _) => Bound i) bounds); |
261 val result = list_comb (t, map (fn (i, _, _, _) => Bound i) bounds); |
218 val terms = HOLogic.mk_list @{typ term} (map (fn (_, i, _, _) => Bound i $ @{term "()"}) bounds); |
262 val terms = HOLogic.mk_list @{typ term} (map (fn (_, i, _, _) => Bound i $ @{term "()"}) bounds); |
219 val check = |
263 val check = |
220 @{term "Smallcheck.catch_match :: term list option => term list option => term list option"} $ |
264 @{term "Smallcheck.catch_match :: term list option => term list option => term list option"} $ |
221 (@{term "If :: bool => term list option => term list option => term list option"} |
265 (@{term "If :: bool => term list option => term list option => term list option"} |
222 $ result $ @{term "None :: term list option"} $ (@{term "Some :: term list => term list option"} $ terms)) |
266 $ result $ @{term "None :: term list option"} $ (@{term "Some :: term list => term list option"} $ terms)) |
226 $ (HOLogic.split_const (T, @{typ "unit => term"}, @{typ "term list option"}) |
270 $ (HOLogic.split_const (T, @{typ "unit => term"}, @{typ "term list option"}) |
227 $ absdummy (T, absdummy (@{typ "unit => term"}, t))) $ Bound i |
271 $ absdummy (T, absdummy (@{typ "unit => term"}, t))) $ Bound i |
228 in Abs ("d", @{typ code_numeral}, fold_rev mk_small_closure bounds check) end |
272 in Abs ("d", @{typ code_numeral}, fold_rev mk_small_closure bounds check) end |
229 |
273 |
230 fun compile_generator_expr ctxt t = |
274 fun compile_generator_expr ctxt t = |
231 let |
275 if Config.get ctxt Quickcheck.report then |
232 val Ts = (map snd o fst o strip_abs) t; |
|
233 val thy = ProofContext.theory_of ctxt |
|
234 in if Config.get ctxt Quickcheck.report then |
|
235 error "Compilation with reporting facility is not supported" |
276 error "Compilation with reporting facility is not supported" |
236 else |
277 else |
237 let |
278 let |
238 val t' = mk_generator_expr thy t Ts; |
279 val thy = ProofContext.theory_of ctxt |
|
280 val t' = |
|
281 (if Config.get ctxt smart_quantifier then mk_smart_generator_expr else mk_generator_expr) |
|
282 ctxt t; |
239 val compile = Code_Runtime.dynamic_value_strict |
283 val compile = Code_Runtime.dynamic_value_strict |
240 (Counterexample.get, put_counterexample, "Smallvalue_Generators.put_counterexample") |
284 (Counterexample.get, put_counterexample, "Smallvalue_Generators.put_counterexample") |
241 thy (SOME target) (fn proc => fn g => g #> (Option.map o map) proc) t' []; |
285 thy (SOME target) (fn proc => fn g => g #> (Option.map o map) proc) t' []; |
242 val dummy_report = ([], false) |
286 val dummy_report = ([], false) |
243 in compile #> rpair dummy_report end |
287 in compile #> rpair dummy_report end; |
244 end; |
|
245 |
288 |
246 (** setup **) |
289 (** setup **) |
247 |
290 |
248 val setup = |
291 val setup = |
249 Datatype.interpretation |
292 Datatype.interpretation |
250 (Quickcheck_Generators.ensure_sort_datatype (@{sort full_small}, instantiate_smallvalue_datatype)) |
293 (Quickcheck_Generators.ensure_sort_datatype (@{sort full_small}, instantiate_smallvalue_datatype)) |
|
294 #> setup_smart_quantifier |
251 #> Context.theory_map |
295 #> Context.theory_map |
252 (Quickcheck.add_generator ("small", compile_generator_expr)); |
296 (Quickcheck.add_generator ("small", compile_generator_expr)); |
253 |
297 |
254 end; |
298 end; |