39 structure Code_Test: CODE_TEST = |
39 structure Code_Test: CODE_TEST = |
40 struct |
40 struct |
41 |
41 |
42 (* convert a list of terms into nested tuples and back *) |
42 (* convert a list of terms into nested tuples and back *) |
43 |
43 |
44 fun mk_tuples [] = @{term "()"} |
44 fun mk_tuples [] = \<^term>\<open>()\<close> |
45 | mk_tuples [t] = t |
45 | mk_tuples [t] = t |
46 | mk_tuples (t :: ts) = HOLogic.mk_prod (t, mk_tuples ts) |
46 | mk_tuples (t :: ts) = HOLogic.mk_prod (t, mk_tuples ts) |
47 |
47 |
48 fun dest_tuples (Const (@{const_name Pair}, _) $ l $ r) = l :: dest_tuples r |
48 fun dest_tuples (Const (\<^const_name>\<open>Pair\<close>, _) $ l $ r) = l :: dest_tuples r |
49 | dest_tuples t = [t] |
49 | dest_tuples t = [t] |
50 |
50 |
51 |
51 |
52 fun last_field sep str = |
52 fun last_field sep str = |
53 let |
53 let |
144 Pretty.blk (0, Pretty.fbreaks (map (pretty_failure ctxt target) failures)) |
144 Pretty.blk (0, Pretty.fbreaks (map (pretty_failure ctxt target) failures)) |
145 |
145 |
146 |
146 |
147 (* driver invocation *) |
147 (* driver invocation *) |
148 |
148 |
149 val overlord = Attrib.setup_config_bool @{binding "code_test_overlord"} (K false) |
149 val overlord = Attrib.setup_config_bool \<^binding>\<open>code_test_overlord\<close> (K false) |
150 |
150 |
151 fun with_overlord_dir name f = |
151 fun with_overlord_dir name f = |
152 let |
152 let |
153 val path = |
153 val path = |
154 Path.append (Path.explode "$ISABELLE_HOME_USER") (Path.basic (name ^ serial_string ())) |
154 Path.append (Path.explode "$ISABELLE_HOME_USER") (Path.basic (name ^ serial_string ())) |
172 in Exn.release (Code_Thingol.dynamic_value ctxt (Exn.map_res o postproc) evaluator t) end |
172 in Exn.release (Code_Thingol.dynamic_value ctxt (Exn.map_res o postproc) evaluator t) end |
173 |
173 |
174 |
174 |
175 (* term preprocessing *) |
175 (* term preprocessing *) |
176 |
176 |
177 fun add_eval (Const (@{const_name Trueprop}, _) $ t) = add_eval t |
177 fun add_eval (Const (\<^const_name>\<open>Trueprop\<close>, _) $ t) = add_eval t |
178 | add_eval (Const (@{const_name "HOL.eq"}, _) $ lhs $ rhs) = (fn acc => |
178 | add_eval (Const (\<^const_name>\<open>HOL.eq\<close>, _) $ lhs $ rhs) = (fn acc => |
179 acc |
179 acc |
180 |> add_eval rhs |
180 |> add_eval rhs |
181 |> add_eval lhs |
181 |> add_eval lhs |
182 |> cons rhs |
182 |> cons rhs |
183 |> cons lhs) |
183 |> cons lhs) |
184 | add_eval (Const (@{const_name "Not"}, _) $ t) = add_eval t |
184 | add_eval (Const (\<^const_name>\<open>Not\<close>, _) $ t) = add_eval t |
185 | add_eval (Const (@{const_name "Orderings.ord_class.less_eq"}, _) $ lhs $ rhs) = (fn acc => |
185 | add_eval (Const (\<^const_name>\<open>Orderings.ord_class.less_eq\<close>, _) $ lhs $ rhs) = (fn acc => |
186 lhs :: rhs :: acc) |
186 lhs :: rhs :: acc) |
187 | add_eval (Const (@{const_name "Orderings.ord_class.less"}, _) $ lhs $ rhs) = (fn acc => |
187 | add_eval (Const (\<^const_name>\<open>Orderings.ord_class.less\<close>, _) $ lhs $ rhs) = (fn acc => |
188 lhs :: rhs :: acc) |
188 lhs :: rhs :: acc) |
189 | add_eval _ = I |
189 | add_eval _ = I |
190 |
190 |
191 fun mk_term_of [] = @{term "None :: (unit \<Rightarrow> yxml_of_term) option"} |
191 fun mk_term_of [] = \<^term>\<open>None :: (unit \<Rightarrow> yxml_of_term) option\<close> |
192 | mk_term_of ts = |
192 | mk_term_of ts = |
193 let |
193 let |
194 val tuple = mk_tuples ts |
194 val tuple = mk_tuples ts |
195 val T = fastype_of tuple |
195 val T = fastype_of tuple |
196 in |
196 in |
197 @{term "Some :: (unit \<Rightarrow> yxml_of_term) \<Rightarrow> (unit \<Rightarrow> yxml_of_term) option"} $ |
197 \<^term>\<open>Some :: (unit \<Rightarrow> yxml_of_term) \<Rightarrow> (unit \<Rightarrow> yxml_of_term) option\<close> $ |
198 (absdummy @{typ unit} (@{const yxml_string_of_term} $ |
198 (absdummy \<^typ>\<open>unit\<close> (@{const yxml_string_of_term} $ |
199 (Const (@{const_name Code_Evaluation.term_of}, T --> @{typ term}) $ tuple))) |
199 (Const (\<^const_name>\<open>Code_Evaluation.term_of\<close>, T --> \<^typ>\<open>term\<close>) $ tuple))) |
200 end |
200 end |
201 |
201 |
202 fun test_terms ctxt ts target = |
202 fun test_terms ctxt ts target = |
203 let |
203 let |
204 val thy = Proof_Context.theory_of ctxt |
204 val thy = Proof_Context.theory_of ctxt |
205 |
205 |
206 fun term_of t = Sign.of_sort thy (fastype_of t, @{sort term_of}) |
206 fun term_of t = Sign.of_sort thy (fastype_of t, \<^sort>\<open>term_of\<close>) |
207 |
207 |
208 fun ensure_bool t = |
208 fun ensure_bool t = |
209 (case fastype_of t of |
209 (case fastype_of t of |
210 @{typ bool} => () |
210 \<^typ>\<open>bool\<close> => () |
211 | _ => |
211 | _ => |
212 error (Pretty.string_of |
212 error (Pretty.string_of |
213 (Pretty.block [Pretty.str "Test case not of type bool:", Pretty.brk 1, |
213 (Pretty.block [Pretty.str "Test case not of type bool:", Pretty.brk 1, |
214 Syntax.pretty_term ctxt t]))) |
214 Syntax.pretty_term ctxt t]))) |
215 |
215 |
259 (Pretty.block (Pretty.str "Term contains free variables:" :: Pretty.brk 1 :: |
259 (Pretty.block (Pretty.str "Term contains free variables:" :: Pretty.brk 1 :: |
260 Pretty.commas (map (pretty_free ctxt) frees)))) |
260 Pretty.commas (map (pretty_free ctxt) frees)))) |
261 |
261 |
262 val T = fastype_of t |
262 val T = fastype_of t |
263 val _ = |
263 val _ = |
264 if Sign.of_sort (Proof_Context.theory_of ctxt) (T, @{sort term_of}) then () |
264 if Sign.of_sort (Proof_Context.theory_of ctxt) (T, \<^sort>\<open>term_of\<close>) then () |
265 else error ("Type " ^ Syntax.string_of_typ ctxt T ^ |
265 else error ("Type " ^ Syntax.string_of_typ ctxt T ^ |
266 " of term not of sort " ^ Syntax.string_of_sort ctxt @{sort term_of}) |
266 " of term not of sort " ^ Syntax.string_of_sort ctxt \<^sort>\<open>term_of\<close>) |
267 |
267 |
268 val t' = |
268 val t' = |
269 HOLogic.mk_list @{typ "bool \<times> (unit \<Rightarrow> yxml_of_term) option"} |
269 HOLogic.mk_list \<^typ>\<open>bool \<times> (unit \<Rightarrow> yxml_of_term) option\<close> |
270 [HOLogic.mk_prod (@{term "False"}, mk_term_of [t])] |
270 [HOLogic.mk_prod (\<^term>\<open>False\<close>, mk_term_of [t])] |
271 |
271 |
272 val result = dynamic_value_strict ctxt t' target |
272 val result = dynamic_value_strict ctxt t' target |
273 in (case result of [(_, SOME [t])] => t | _ => error "Evaluation failed") end |
273 in (case result of [(_, SOME [t])] => t | _ => error "Evaluation failed") end |
274 |
274 |
275 |
275 |
571 |
571 |
572 |
572 |
573 (* command setup *) |
573 (* command setup *) |
574 |
574 |
575 val _ = |
575 val _ = |
576 Outer_Syntax.command @{command_keyword test_code} |
576 Outer_Syntax.command \<^command_keyword>\<open>test_code\<close> |
577 "compile test cases to target languages, execute them and report results" |
577 "compile test cases to target languages, execute them and report results" |
578 (Scan.repeat1 Parse.prop -- (@{keyword "in"} |-- Scan.repeat1 Parse.name) |
578 (Scan.repeat1 Parse.prop -- (\<^keyword>\<open>in\<close> |-- Scan.repeat1 Parse.name) |
579 >> (fn (ts, targets) => Toplevel.keep (test_code_cmd ts targets o Toplevel.context_of))) |
579 >> (fn (ts, targets) => Toplevel.keep (test_code_cmd ts targets o Toplevel.context_of))) |
580 |
580 |
581 val target_Scala = "Scala_eval" |
581 val target_Scala = "Scala_eval" |
582 val target_Haskell = "Haskell_eval" |
582 val target_Haskell = "Haskell_eval" |
583 |
583 |