190 end) () |
190 end) () |
191 handle TimeLimit.TimeOut => |
191 handle TimeLimit.TimeOut => |
192 if is_interactive then error (excipit "ran out of time") else raise TimeLimit.TimeOut |
192 if is_interactive then error (excipit "ran out of time") else raise TimeLimit.TimeOut |
193 end; |
193 end; |
194 |
194 |
|
195 fun test_term_with_increasing_cardinality ctxt is_interactive ts = |
|
196 let |
|
197 val (namess, ts') = split_list (map prep_test_term ts) |
|
198 val (test_funs, comp_time) = cpu_time "quickcheck compilation" |
|
199 (fn () => map (mk_tester ctxt) ts') |
|
200 fun test_card_size (card, size) = |
|
201 (* FIXME: why decrement size by one? *) |
|
202 case fst (the (nth test_funs (card - 1)) (size - 1)) of |
|
203 SOME ts => SOME ((nth namess (card - 1)) ~~ ts) |
|
204 | NONE => NONE |
|
205 val enumeration_card_size = |
|
206 map_product pair (1 upto (length ts)) (1 upto (Config.get ctxt size)) |
|
207 |> sort (fn ((c1, s1), (c2, s2)) => int_ord ((c1 + s1), (c2 + s2))) |
|
208 in |
|
209 if (forall is_none test_funs) then |
|
210 (NONE, ([comp_time], NONE)) |
|
211 else if (forall is_some test_funs) then |
|
212 TimeLimit.timeLimit (seconds (Config.get ctxt timeout)) (fn () => |
|
213 (get_first test_card_size enumeration_card_size, ([comp_time], NONE))) () |
|
214 handle TimeLimit.TimeOut => |
|
215 if is_interactive then error ("Quickcheck ran out of time") else raise TimeLimit.TimeOut |
|
216 else |
|
217 error "Unexpectedly, testers of some cardinalities are executable but others are not" |
|
218 end |
|
219 |
195 fun get_finite_types ctxt = |
220 fun get_finite_types ctxt = |
196 fst (chop (Config.get ctxt finite_type_size) |
221 fst (chop (Config.get ctxt finite_type_size) |
197 (map (Type o rpair []) ["Enum.finite_1", "Enum.finite_2", "Enum.finite_3", |
222 (map (Type o rpair []) ["Enum.finite_1", "Enum.finite_2", "Enum.finite_3", |
198 "Enum.finite_4", "Enum.finite_5"])) |
223 "Enum.finite_4", "Enum.finite_5"])) |
199 |
224 |
221 let |
246 let |
222 val thy = ProofContext.theory_of lthy |
247 val thy = ProofContext.theory_of lthy |
223 val default_insts = |
248 val default_insts = |
224 if Config.get lthy finite_types then (get_finite_types lthy) else (default_type lthy) |
249 if Config.get lthy finite_types then (get_finite_types lthy) else (default_type lthy) |
225 val inst_goals = |
250 val inst_goals = |
226 maps (fn check_goal => |
251 map (fn check_goal => |
227 if not (null (Term.add_tfree_names check_goal [])) then |
252 if not (null (Term.add_tfree_names check_goal [])) then |
228 map (fn T => |
253 map (fn T => |
229 ((Term o Object_Logic.atomize_term thy o monomorphic_term thy insts T) check_goal) |
254 (pair (SOME T) o Term o Object_Logic.atomize_term thy o monomorphic_term thy insts T) check_goal |
230 handle WELLSORTED s => Wellsorted_Error s) default_insts |
255 handle WELLSORTED s => (SOME T, Wellsorted_Error s)) default_insts |
231 else |
256 else |
232 [Term (Object_Logic.atomize_term thy check_goal)]) check_goals |
257 [(NONE, Term (Object_Logic.atomize_term thy check_goal))]) check_goals |
233 val error_msg = cat_lines (map_filter (fn Term t => NONE | Wellsorted_Error s => SOME s) inst_goals) |
258 val error_msg = cat_lines (maps (map_filter (fn (_, Term t) => NONE | (_, Wellsorted_Error s) => SOME s)) inst_goals) |
|
259 fun is_wellsorted_term (T, Term t) = SOME (T, t) |
|
260 | is_wellsorted_term (_, Wellsorted_Error s) = NONE |
234 val correct_inst_goals = |
261 val correct_inst_goals = |
235 case map_filter (fn Term t => SOME t | Wellsorted_Error s => NONE) inst_goals of |
262 case map (map_filter is_wellsorted_term) inst_goals of |
236 [] => error error_msg |
263 [[]] => error error_msg |
237 | xs => xs |
264 | xs => xs |
238 val _ = if Config.get lthy quiet then () else warning error_msg |
265 val _ = if Config.get lthy quiet then () else warning error_msg |
239 fun collect_results f reports [] = (NONE, rev reports) |
266 fun collect_results f reports [] = (NONE, rev reports) |
240 | collect_results f reports (t :: ts) = |
267 | collect_results f reports (t :: ts) = |
241 case f t of |
268 case f t of |
242 (SOME res, report) => (SOME res, rev (report :: reports)) |
269 (SOME res, report) => (SOME res, rev (report :: reports)) |
243 | (NONE, report) => collect_results f (report :: reports) ts |
270 | (NONE, report) => collect_results f (report :: reports) ts |
244 in collect_results (test_term lthy is_interactive) [] correct_inst_goals end; |
271 fun test_term' goal = |
|
272 case goal of |
|
273 [(NONE, t)] => test_term lthy is_interactive t |
|
274 | ts => test_term_with_increasing_cardinality lthy is_interactive (map snd ts) |
|
275 in |
|
276 if Config.get lthy finite_types then |
|
277 collect_results test_term' [] correct_inst_goals |
|
278 else |
|
279 collect_results (test_term lthy is_interactive) [] (maps (map snd) correct_inst_goals) |
|
280 end; |
245 |
281 |
246 fun test_goal insts i state = |
282 fun test_goal insts i state = |
247 let |
283 let |
248 val lthy = Proof.context_of state; |
284 val lthy = Proof.context_of state; |
249 val thy = Proof.theory_of state; |
285 val thy = Proof.theory_of state; |