42 val get_defn: theory -> string -> typ -> ((term list * term) * int option) option |
42 val get_defn: theory -> string -> typ -> ((term list * term) * int option) option |
43 val is_instance: theory -> typ -> typ -> bool |
43 val is_instance: theory -> typ -> typ -> bool |
44 val parens: Pretty.T -> Pretty.T |
44 val parens: Pretty.T -> Pretty.T |
45 val mk_app: bool -> Pretty.T -> Pretty.T list -> Pretty.T |
45 val mk_app: bool -> Pretty.T -> Pretty.T list -> Pretty.T |
46 val eta_expand: term -> term list -> int -> term |
46 val eta_expand: term -> term list -> int -> term |
|
47 val strip_tname: string -> string |
47 val mk_type: bool -> typ -> Pretty.T |
48 val mk_type: bool -> typ -> Pretty.T |
48 val mk_term_of: Sign.sg -> bool -> typ -> Pretty.T |
49 val mk_term_of: Sign.sg -> bool -> typ -> Pretty.T |
|
50 val mk_gen: Sign.sg -> bool -> string list -> string -> typ -> Pretty.T |
|
51 val test_fn: (int -> (string * term) list option) ref |
|
52 val test_term: theory -> int -> int -> term -> (string * term) list option |
49 val parse_mixfix: (string -> 'a) -> string -> 'a mixfix list |
53 val parse_mixfix: (string -> 'a) -> string -> 'a mixfix list |
50 val parsers: OuterSyntax.parser list |
54 val parsers: OuterSyntax.parser list |
51 val setup: (theory -> theory) list |
55 val setup: (theory -> theory) list |
52 end; |
56 end; |
53 |
57 |
85 fun num_args x = length (filter is_arg x); |
89 fun num_args x = length (filter is_arg x); |
86 |
90 |
87 |
91 |
88 (**** theory data ****) |
92 (**** theory data ****) |
89 |
93 |
90 (* data kind 'Pure/codegen' *) |
94 (* type of code generators *) |
91 |
95 |
92 type 'a codegen = theory -> (exn option * string) Graph.T -> |
96 type 'a codegen = theory -> (exn option * string) Graph.T -> |
93 string -> bool -> 'a -> ((exn option * string) Graph.T * Pretty.T) option; |
97 string -> bool -> 'a -> ((exn option * string) Graph.T * Pretty.T) option; |
94 |
98 |
|
99 (* parameters for random testing *) |
|
100 |
|
101 type test_params = |
|
102 {size: int, iterations: int, default_type: typ option}; |
|
103 |
|
104 fun merge_test_params |
|
105 {size = size1, iterations = iterations1, default_type = default_type1} |
|
106 {size = size2, iterations = iterations2, default_type = default_type2} = |
|
107 {size = Int.max (size1, size2), |
|
108 iterations = Int.max (iterations1, iterations2), |
|
109 default_type = case default_type1 of |
|
110 None => default_type2 |
|
111 | _ => default_type1}; |
|
112 |
|
113 val default_test_params : test_params = |
|
114 {size = 10, iterations = 100, default_type = None}; |
|
115 |
|
116 fun set_size size ({iterations, default_type, ...} : test_params) = |
|
117 {size = size, iterations = iterations, default_type = default_type}; |
|
118 |
|
119 fun set_iterations iterations ({size, default_type, ...} : test_params) = |
|
120 {size = size, iterations = iterations, default_type = default_type}; |
|
121 |
|
122 fun set_default_type s sg ({size, iterations, ...} : test_params) = |
|
123 {size = size, iterations = iterations, |
|
124 default_type = Some (typ_of (read_ctyp sg s))}; |
|
125 |
|
126 (* data kind 'Pure/codegen' *) |
|
127 |
95 structure CodegenArgs = |
128 structure CodegenArgs = |
96 struct |
129 struct |
97 val name = "Pure/codegen"; |
130 val name = "Pure/codegen"; |
98 type T = |
131 type T = |
99 {codegens : (string * term codegen) list, |
132 {codegens : (string * term codegen) list, |
100 tycodegens : (string * typ codegen) list, |
133 tycodegens : (string * typ codegen) list, |
101 consts : ((string * typ) * term mixfix list) list, |
134 consts : ((string * typ) * term mixfix list) list, |
102 types : (string * typ mixfix list) list, |
135 types : (string * typ mixfix list) list, |
103 attrs: (string * theory attribute) list}; |
136 attrs: (string * theory attribute) list, |
|
137 test_params: test_params}; |
104 |
138 |
105 val empty = |
139 val empty = |
106 {codegens = [], tycodegens = [], consts = [], types = [], attrs = []}; |
140 {codegens = [], tycodegens = [], consts = [], types = [], attrs = [], |
|
141 test_params = default_test_params}; |
107 val copy = I; |
142 val copy = I; |
108 val prep_ext = I; |
143 val prep_ext = I; |
109 |
144 |
110 fun merge |
145 fun merge |
111 ({codegens = codegens1, tycodegens = tycodegens1, |
146 ({codegens = codegens1, tycodegens = tycodegens1, |
112 consts = consts1, types = types1, attrs = attrs1}, |
147 consts = consts1, types = types1, attrs = attrs1, |
|
148 test_params = test_params1}, |
113 {codegens = codegens2, tycodegens = tycodegens2, |
149 {codegens = codegens2, tycodegens = tycodegens2, |
114 consts = consts2, types = types2, attrs = attrs2}) = |
150 consts = consts2, types = types2, attrs = attrs2, |
|
151 test_params = test_params2}) = |
115 {codegens = rev (merge_alists (rev codegens1) (rev codegens2)), |
152 {codegens = rev (merge_alists (rev codegens1) (rev codegens2)), |
116 tycodegens = rev (merge_alists (rev tycodegens1) (rev tycodegens2)), |
153 tycodegens = rev (merge_alists (rev tycodegens1) (rev tycodegens2)), |
117 consts = merge_alists consts1 consts2, |
154 consts = merge_alists consts1 consts2, |
118 types = merge_alists types1 types2, |
155 types = merge_alists types1 types2, |
119 attrs = merge_alists attrs1 attrs2}; |
156 attrs = merge_alists attrs1 attrs2, |
|
157 test_params = merge_test_params test_params1 test_params2}; |
120 |
158 |
121 fun print sg ({codegens, tycodegens, ...} : T) = |
159 fun print sg ({codegens, tycodegens, ...} : T) = |
122 Pretty.writeln (Pretty.chunks |
160 Pretty.writeln (Pretty.chunks |
123 [Pretty.strs ("term code generators:" :: map fst codegens), |
161 [Pretty.strs ("term code generators:" :: map fst codegens), |
124 Pretty.strs ("type code generators:" :: map fst tycodegens)]); |
162 Pretty.strs ("type code generators:" :: map fst tycodegens)]); |
126 |
164 |
127 structure CodegenData = TheoryDataFun(CodegenArgs); |
165 structure CodegenData = TheoryDataFun(CodegenArgs); |
128 val print_codegens = CodegenData.print; |
166 val print_codegens = CodegenData.print; |
129 |
167 |
130 |
168 |
|
169 (**** access parameters for random testing ****) |
|
170 |
|
171 fun get_test_params thy = #test_params (CodegenData.get thy); |
|
172 |
|
173 fun map_test_params f thy = |
|
174 let val {codegens, tycodegens, consts, types, attrs, test_params} = |
|
175 CodegenData.get thy; |
|
176 in CodegenData.put {codegens = codegens, tycodegens = tycodegens, |
|
177 consts = consts, types = types, attrs = attrs, |
|
178 test_params = f test_params} thy |
|
179 end; |
|
180 |
|
181 |
131 (**** add new code generators to theory ****) |
182 (**** add new code generators to theory ****) |
132 |
183 |
133 fun add_codegen name f thy = |
184 fun add_codegen name f thy = |
134 let val {codegens, tycodegens, consts, types, attrs} = CodegenData.get thy |
185 let val {codegens, tycodegens, consts, types, attrs, test_params} = |
|
186 CodegenData.get thy |
135 in (case assoc (codegens, name) of |
187 in (case assoc (codegens, name) of |
136 None => CodegenData.put {codegens = (name, f) :: codegens, |
188 None => CodegenData.put {codegens = (name, f) :: codegens, |
137 tycodegens = tycodegens, consts = consts, types = types, |
189 tycodegens = tycodegens, consts = consts, types = types, |
138 attrs = attrs} thy |
190 attrs = attrs, test_params = test_params} thy |
139 | Some _ => error ("Code generator " ^ name ^ " already declared")) |
191 | Some _ => error ("Code generator " ^ name ^ " already declared")) |
140 end; |
192 end; |
141 |
193 |
142 fun add_tycodegen name f thy = |
194 fun add_tycodegen name f thy = |
143 let val {codegens, tycodegens, consts, types, attrs} = CodegenData.get thy |
195 let val {codegens, tycodegens, consts, types, attrs, test_params} = |
|
196 CodegenData.get thy |
144 in (case assoc (tycodegens, name) of |
197 in (case assoc (tycodegens, name) of |
145 None => CodegenData.put {tycodegens = (name, f) :: tycodegens, |
198 None => CodegenData.put {tycodegens = (name, f) :: tycodegens, |
146 codegens = codegens, consts = consts, types = types, |
199 codegens = codegens, consts = consts, types = types, |
147 attrs = attrs} thy |
200 attrs = attrs, test_params = test_params} thy |
148 | Some _ => error ("Code generator " ^ name ^ " already declared")) |
201 | Some _ => error ("Code generator " ^ name ^ " already declared")) |
149 end; |
202 end; |
150 |
203 |
151 |
204 |
152 (**** code attribute ****) |
205 (**** code attribute ****) |
153 |
206 |
154 fun add_attribute name att thy = |
207 fun add_attribute name att thy = |
155 let val {codegens, tycodegens, consts, types, attrs} = CodegenData.get thy |
208 let val {codegens, tycodegens, consts, types, attrs, test_params} = |
|
209 CodegenData.get thy |
156 in (case assoc (attrs, name) of |
210 in (case assoc (attrs, name) of |
157 None => CodegenData.put {tycodegens = tycodegens, |
211 None => CodegenData.put {tycodegens = tycodegens, |
158 codegens = codegens, consts = consts, types = types, |
212 codegens = codegens, consts = consts, types = types, |
159 attrs = (name, att) :: attrs} thy |
213 attrs = (name, att) :: attrs, test_params = test_params} thy |
160 | Some _ => error ("Code attribute " ^ name ^ " already declared")) |
214 | Some _ => error ("Code attribute " ^ name ^ " already declared")) |
161 end; |
215 end; |
162 |
216 |
163 val code_attr = |
217 val code_attr = |
164 Attrib.syntax (Scan.depend (fn thy => Scan.optional Args.name "" >> |
218 Attrib.syntax (Scan.depend (fn thy => Scan.optional Args.name "" >> |
199 |
254 |
200 (**** associate types with target language types ****) |
255 (**** associate types with target language types ****) |
201 |
256 |
202 fun assoc_types xs thy = foldl (fn (thy, (s, syn)) => |
257 fun assoc_types xs thy = foldl (fn (thy, (s, syn)) => |
203 let |
258 let |
204 val {codegens, tycodegens, consts, types, attrs} = CodegenData.get thy; |
259 val {codegens, tycodegens, consts, types, attrs, test_params} = |
|
260 CodegenData.get thy; |
205 val tc = Sign.intern_tycon (sign_of thy) s |
261 val tc = Sign.intern_tycon (sign_of thy) s |
206 in |
262 in |
207 (case assoc (types, tc) of |
263 (case assoc (types, tc) of |
208 None => CodegenData.put {codegens = codegens, |
264 None => CodegenData.put {codegens = codegens, |
209 tycodegens = tycodegens, consts = consts, |
265 tycodegens = tycodegens, consts = consts, |
210 types = (tc, syn) :: types, attrs = attrs} thy |
266 types = (tc, syn) :: types, attrs = attrs, |
|
267 test_params = test_params} thy |
211 | Some _ => error ("Type " ^ tc ^ " already associated with code")) |
268 | Some _ => error ("Type " ^ tc ^ " already associated with code")) |
212 end) (thy, xs); |
269 end) (thy, xs); |
213 |
270 |
214 fun get_assoc_type thy s = assoc (#types (CodegenData.get thy), s); |
271 fun get_assoc_type thy s = assoc (#types (CodegenData.get thy), s); |
215 |
272 |
339 fun default_codegen thy gr dep brack t = |
396 fun default_codegen thy gr dep brack t = |
340 let |
397 let |
341 val (u, ts) = strip_comb t; |
398 val (u, ts) = strip_comb t; |
342 fun codegens brack = foldl_map (invoke_codegen thy dep brack) |
399 fun codegens brack = foldl_map (invoke_codegen thy dep brack) |
343 in (case u of |
400 in (case u of |
344 Var ((s, i), _) => |
401 Var ((s, i), T) => |
345 let val (gr', ps) = codegens true (gr, ts) |
402 let |
346 in Some (gr', mk_app brack (Pretty.str (s ^ |
403 val (gr', ps) = codegens true (gr, ts); |
|
404 val (gr'', _) = invoke_tycodegen thy dep false (gr', T) |
|
405 in Some (gr'', mk_app brack (Pretty.str (s ^ |
347 (if i=0 then "" else string_of_int i))) ps) |
406 (if i=0 then "" else string_of_int i))) ps) |
348 end |
407 end |
349 |
408 |
350 | Free (s, _) => |
409 | Free (s, T) => |
351 let val (gr', ps) = codegens true (gr, ts) |
410 let |
352 in Some (gr', mk_app brack (Pretty.str s) ps) end |
411 val (gr', ps) = codegens true (gr, ts); |
|
412 val (gr'', _) = invoke_tycodegen thy dep false (gr', T) |
|
413 in Some (gr'', mk_app brack (Pretty.str s) ps) end |
353 |
414 |
354 | Const (s, T) => |
415 | Const (s, T) => |
355 (case get_assoc_code thy s T of |
416 (case get_assoc_code thy s T of |
356 Some ms => |
417 Some ms => |
357 let val i = num_args ms |
418 let val i = num_args ms |
471 | mk_term_of sg p (Type (s, Ts)) = (if p then parens else I) (Pretty.block |
532 | mk_term_of sg p (Type (s, Ts)) = (if p then parens else I) (Pretty.block |
472 (separate (Pretty.brk 1) (Pretty.str ("term_of_" ^ mk_type_id sg s) :: |
533 (separate (Pretty.brk 1) (Pretty.str ("term_of_" ^ mk_type_id sg s) :: |
473 flat (map (fn T => [mk_term_of sg true T, mk_type true T]) Ts)))); |
534 flat (map (fn T => [mk_term_of sg true T, mk_type true T]) Ts)))); |
474 |
535 |
475 |
536 |
|
537 (**** Test data generators ****) |
|
538 |
|
539 fun mk_gen sg p xs a (TVar ((s, i), _)) = Pretty.str |
|
540 (strip_tname s ^ (if i = 0 then "" else string_of_int i) ^ "G") |
|
541 | mk_gen sg p xs a (TFree (s, _)) = Pretty.str (strip_tname s ^ "G") |
|
542 | mk_gen sg p xs a (Type (s, Ts)) = (if p then parens else I) (Pretty.block |
|
543 (separate (Pretty.brk 1) (Pretty.str ("gen_" ^ mk_type_id sg s ^ |
|
544 (if s mem xs then "'" else "")) :: map (mk_gen sg true xs a) Ts @ |
|
545 (if s mem xs then [Pretty.str a] else [])))); |
|
546 |
|
547 val test_fn : (int -> (string * term) list option) ref = ref (fn _ => None); |
|
548 |
|
549 fun test_term thy sz i t = |
|
550 let |
|
551 val _ = assert (null (term_tvars t) andalso null (term_tfrees t)) |
|
552 "Term to be tested contains type variables"; |
|
553 val _ = assert (null (term_vars t)) |
|
554 "Term to be tested contains schematic variables"; |
|
555 val sg = sign_of thy; |
|
556 val frees = map dest_Free (term_frees t); |
|
557 val s = "structure TestTerm =\nstruct\n\n" ^ |
|
558 setmp mode ["term_of", "test"] (generate_code_i thy) |
|
559 [("testf", list_abs_free (frees, t))] ^ |
|
560 "\n" ^ Pretty.string_of |
|
561 (Pretty.block [Pretty.str "val () = Codegen.test_fn :=", |
|
562 Pretty.brk 1, Pretty.str "(fn i =>", Pretty.brk 1, |
|
563 Pretty.blk (0, [Pretty.str "let", Pretty.brk 1, |
|
564 Pretty.blk (0, separate Pretty.fbrk (map (fn (s, T) => |
|
565 Pretty.block [Pretty.str ("val " ^ s ^ " ="), Pretty.brk 1, |
|
566 mk_gen sg false [] "" T, Pretty.brk 1, |
|
567 Pretty.str "i;"]) frees)), |
|
568 Pretty.brk 1, Pretty.str "in", Pretty.brk 1, |
|
569 Pretty.block [Pretty.str "if ", |
|
570 mk_app false (Pretty.str "testf") (map (Pretty.str o fst) frees), |
|
571 Pretty.brk 1, Pretty.str "then None", |
|
572 Pretty.brk 1, Pretty.str "else ", |
|
573 Pretty.block [Pretty.str "Some ", Pretty.block (Pretty.str "[" :: |
|
574 flat (separate [Pretty.str ",", Pretty.brk 1] |
|
575 (map (fn (s, T) => [Pretty.block |
|
576 [Pretty.str ("(" ^ quote s ^ ","), Pretty.brk 1, |
|
577 mk_app false (mk_term_of sg false T) |
|
578 [Pretty.str s], Pretty.str ")"]]) frees)) @ |
|
579 [Pretty.str "]"])]], |
|
580 Pretty.brk 1, Pretty.str "end"]), Pretty.str ");"]) ^ |
|
581 "\n\nend;\n"; |
|
582 val _ = use_text Context.ml_output false s; |
|
583 fun iter f k = if k > i then None |
|
584 else (case f () of None => iter f (k+1) | Some x => Some x); |
|
585 fun test k = if k > sz then None |
|
586 else (priority ("Test data size: " ^ string_of_int k); |
|
587 case iter (fn () => !test_fn k) 1 of |
|
588 None => test (k+1) | Some x => Some x); |
|
589 in test 0 end; |
|
590 |
|
591 fun test_goal ({size, iterations, default_type}, tvinsts) i st = |
|
592 let |
|
593 val sg = Toplevel.sign_of st; |
|
594 fun strip (Const ("all", _) $ Abs (_, _, t)) = strip t |
|
595 | strip t = t; |
|
596 val (gi, frees) = Logic.goal_params |
|
597 (prop_of (snd (snd (Proof.get_goal (Toplevel.proof_of st))))) i; |
|
598 val gi' = ObjectLogic.atomize_term sg (map_term_types |
|
599 (map_type_tfree (fn p as (s, _) => if_none (assoc (tvinsts, s)) |
|
600 (if_none default_type (TFree p)))) (subst_bounds (frees, strip gi))); |
|
601 in case test_term (Toplevel.theory_of st) size iterations gi' of |
|
602 None => writeln "No counterexamples found." |
|
603 | Some cex => writeln ("Counterexample found:\n" ^ |
|
604 Pretty.string_of (Pretty.chunks (map (fn (s, t) => |
|
605 Pretty.block [Pretty.str (s ^ " ="), Pretty.brk 1, |
|
606 Sign.pretty_term sg t]) cex))) |
|
607 end; |
|
608 |
|
609 |
476 (**** Interface ****) |
610 (**** Interface ****) |
477 |
611 |
478 val str = setmp print_mode [] Pretty.str; |
612 val str = setmp print_mode [] Pretty.str; |
479 |
613 |
480 fun parse_mixfix rd s = |
614 fun parse_mixfix rd s = |
524 ((case opt_fname of |
658 ((case opt_fname of |
525 None => use_text Context.ml_output false |
659 None => use_text Context.ml_output false |
526 | Some fname => File.write (Path.unpack fname)) |
660 | Some fname => File.write (Path.unpack fname)) |
527 (setmp mode mode' (generate_code thy) xs); thy)))); |
661 (setmp mode mode' (generate_code thy) xs); thy)))); |
528 |
662 |
529 val parsers = [assoc_typeP, assoc_constP, generate_codeP]; |
663 val params = |
|
664 [("size", P.nat >> (K o set_size)), |
|
665 ("iterations", P.nat >> (K o set_iterations)), |
|
666 ("default_type", P.typ >> set_default_type)]; |
|
667 |
|
668 val parse_test_params = P.short_ident :-- (fn s => |
|
669 P.$$$ "=" |-- if_none (assoc (params, s)) Scan.fail) >> snd; |
|
670 |
|
671 fun parse_tyinst xs = |
|
672 (P.type_ident --| P.$$$ "=" -- P.typ >> (fn (v, s) => fn sg => |
|
673 fn (x, ys) => (x, (v, typ_of (read_ctyp sg s)) :: ys))) xs; |
|
674 |
|
675 fun app [] x = x |
|
676 | app (f :: fs) x = app fs (f x); |
|
677 |
|
678 val test_paramsP = |
|
679 OuterSyntax.command "quickcheck_params" "set parameters for random testing" K.thy_decl |
|
680 (P.$$$ "[" |-- P.list1 parse_test_params --| P.$$$ "]" >> |
|
681 (fn fs => Toplevel.theory (fn thy => |
|
682 map_test_params (app (map (fn f => f (sign_of thy)) fs)) thy))); |
|
683 |
|
684 val testP = |
|
685 OuterSyntax.command "quickcheck" "try to find counterexample for subgoal" K.diag |
|
686 (Scan.option (P.$$$ "[" |-- P.list1 |
|
687 ( parse_test_params >> (fn f => fn sg => apfst (f sg)) |
|
688 || parse_tyinst) --| P.$$$ "]") -- Scan.optional P.nat 1 >> |
|
689 (fn (ps, g) => Toplevel.keep (fn st => |
|
690 test_goal (app (if_none (apsome |
|
691 (map (fn f => f (Toplevel.sign_of st))) ps) []) |
|
692 (get_test_params (Toplevel.theory_of st), [])) g st))); |
|
693 |
|
694 val parsers = [assoc_typeP, assoc_constP, generate_codeP, test_paramsP, testP]; |
530 |
695 |
531 val setup = |
696 val setup = |
532 [CodegenData.init, |
697 [CodegenData.init, |
533 add_codegen "default" default_codegen, |
698 add_codegen "default" default_codegen, |
534 add_tycodegen "default" default_tycodegen, |
699 add_tycodegen "default" default_tycodegen, |